How can I solve this transcendental equation in Mathematica?

Question

I want to solve the following equation

$\frac{Sin[a[x]]}{a[x]}$ - x = 0, for x in range {0,1}.

I tried the FindRoot method but it gives only one root. I want to find the roots for this equation for all x in the range {0,1}.

As I'm new to Mathematica I'm unable to solve this using some known answers like this one.

Answer 1

You can use Solve to find the roots. Here is a function that finds the roots between $-\pi$ and $\pi$:

f[x_] := a /. Solve[Sin[a]/a==x && -Pi < a < Pi, a, Reals]

Examples:

f[1/2]
f[1/10]

{Root[{-2 Sin[#1] + #1 &, -1.89549426703398094714}], Root[{-2 Sin[#1] + #1 &, 1.89549426703398094714}]}

{Root[{-10 Sin[#1] + #1 &, -2.8523418944500916483}], Root[{-10 Sin[#1] + #1 &, 2.8523418944500916483}]}

You can use N to obtain approximate answers:

N[f[1/100], 40]

{-3.110482807621505335413758229364966288043, 3.110482807621505335413758229364966288043}

Answer 2

As your equation is Sinc[a] == x the formal solution is

A = InverseFunction[Sinc];

You can plot it with

Plot[A[x], {x, -0.21723362821122166`, 1}]

but as you see in the result you get a random branch of the solution:

Better to use something numeric: the $i^{\text{th}}$ branch is found numerically by starting a FindRoot at the quadratic approximation of the relevant branch (only positive branches $a>0$):

Clear[B];
B[0, x_?NumericQ] := a /. FindRoot[Sinc[a] == x, {a, Sqrt[6 (1 - x)]}]
B[i_?OddQ, x_?NumericQ] := a /. FindRoot[Sinc[a] == x,
  {a, ((3+2i)π((3+2i)^2*π^2-2(6+Sqrt[-12+(3+2i)π(8x+(3+2i)π(2-(3+2i)π*x))])))/(-16+2(3+2i)^2*π^2)}]
B[i_?EvenQ, x_?NumericQ] := a /. FindRoot[Sinc[a] == x,
  {a, ((1+2i)π((π+2i*π)^2+2(-6+Sqrt[-12+(1+2i)π((2+4i)π+8x-(π+2i*π)^2*x)])))/(2(-8+(π+2i*π)^2))}]

Table[B[i, 0.03], {i, 0, 10}]

{3.04997, 6.47879, 9.14681, 12.9659, 15.2333, 19.4735, 21.298, 26.0288, 27.3139, 32.8091, 33.1041}

With[{z = 0.03},
  Plot[Sinc[a], {a, 0, 35}, GridLines -> {None, {z}}, 
    Epilog -> {Red, Table[Point[{B[i, z], z}], {i, 0, 10}]}]]

Answer 3

In order to find all of the roots for $x$ in range $\{0,1\}$, (without placing a limit on the range of $a$), you should use reduce. Because the user specifically wrote the function as $\sin(a)/a = z$ we do not convert the equation to $\text{sinc}(a)$, and specifically exclude the point $a=0$ because this would put a zero in the denominator.

f[yMax_, x_] := f[yMax, x] =
    If[x != 1,
        If[x != 0 ,
            {ToRules[N[Reduce[Sin[a]/a == x, a, Reals]]]},
            DeleteCases[Flatten[Table[ FullSimplify[Solve[Sin[a]/a == 0, a, Reals], a != 0 && C[1] \[Element] Integers] /. C[1] -> iConst, {iConst, -IntegerPart[yMax],  IntegerPart[yMax]}], 1], {a -> 0}]],
{}]

Writing all of the solutions for a particular value of x, as an array of ordered pairs gives,

finalFunction[yMax_, x_] := If[f[yMax, x] != {},
    {x, a} /. f[yMax, x],
    Nothing]

We can list all of the roots for values $x$ in the range $\{0,1\}$ to an arbitrary resolution in values of $x$ using the function,

listAllRoots[yMax_, resolution_] := listAllRoots[yMax, resolution] = SortBy[Flatten[ParallelTable[N[finalFunction[yMax, x]], {x, -1,1,1/resolution}], 1], Last]

Plotting all of these values at different scales of $a(x)$ using the function,

finalPlot[yMax_, resolution_] := ListLinePlot[
    listAllRoots[yMax,resolution],
    AspectRatio -> .75,
    PlotRange -> {{Automatic,1.0554}, {-yMax - .1*yMax, +yMax + .1*yMax}},
    LabelStyle -> {FontFamily -> "Latex", FontSize -> 25},
    FrameLabel -> {"x", "a(x)"},
    FrameTicks -> {{Table[Round[i, 1], {i, -yMax, yMax, yMax/3}], None},{Automatic, None}},
    PlotTheme -> "Scientific", ImageSize -> 450]

Here we have plotted all of the roots to the transcendental equation. Note that at $x=0$ the full solution is $a=n\pi$ where $n$ is any positive or negative integer. Thus there are infinite solutions at $x=0$, so here we have used the parameter $\text{yMax}$ to only solve for values $a=\{-\text{yMax},\text{yMax}\}$, which are within the plotting window. This value may be arbitrarily adjusted to any value.

GraphicsRow[{finalPlot[3, 500], finalPlot[30, 500], finalPlot[90, 500]}]

Answer 4

The problem is symmetric in a , {x,a} and {x,-a} solve the equation. Try

pic= ContourPlot[(Sin[a ]/a ) - x == 0, {x, 0, 1}, {a, 0, Pi},FrameLabel -> {x, a}]

to see the solution of your equation. I don't think that an analytical solution exists.

Now you can get the solutionpoints from pic

xa = pic[[1, 1]];

and interpolate

ip = Interpolation[xa] (*ip[x]=a[x]*)
Show[{pic, Plot[ip[x], {x, 0, 1},PlotStyle -> {Thickness[.01], Opacity[.3], Red}]}]