Looking for (possibly) two roots with FindRoot

I am looking for intersections of the a family of functions $$F_n(k)$$ defined over $$[0,1)$$

$$\frac{2K(k)n}{\frac{1+k}{\sqrt{1+k^2}}}$$ where $$K$$ is the complete elliptic integral of the first kind, with the constant function $$g = L$$.

Depending on $$n$$ there might be one or two intersections, as the image below will clarify (the $$n=1,2$$ curves are drawn).

My task: given a $$L$$, I need to find the intersection(s) with each $$F_n$$ curve, and store the related $$k$$ coordinates for later work, during which I will still be interested to know which $$n$$ index the intersection coordinates refer to.

What I thought about doing, to get going, is to create a $$n \times 2$$ table and store in each row the two intersection coordinates: if only one root is there, store the same values, maybe ignore one, etc.

Before getting to the table, I need to be able to find the roots.

Given the curves "shape", I thought about using FindRoot, feeding it $$0$$ and $$0.9999$$ as starting guesses (the function diverges at $$k=1$$): this way I should nicely capture both intersections, but I am not sure at all this is the best way.

Anyhow, the intercepts $$y_n$$ with the vertical axis are given by $$F_n(0) =n \pi$$. Let us then try with $$n=1$$ and $$L=3$$, expecting hence two roots.

Checking how it works:

fn[ k_, n_] := 2*EllipticK[k]*n/(   (1 + k)/Sqrt[1 + k^2])
FindRoot[f1[k, 1] - 3, {k, 0.0, 0 , 1}]
{k -> 0.0682733}
FindRoot[f1[k, 1] - 3, {k, 0.99, 0 , 1}]
{k -> 0.710837}


Works as I would like it. Let us then try with $$L=3.4$$, one root expected. Starting from "the right"

FindRoot[f1[k, 1] - 3.4, {k, 0.99, 0 , 1}]
{k -> 0.852433}


but when starting from the left, $$k=0$$

  FindRoot[f1[k, 1] - 3.4, {k, 0.0, 0 , 1}]
FindRoot::reged: The point {-2.77556*10^-17} is at the edge of the search region {0.,1.} in    coordinate 1 and the computed search direction points outside the region.


If no search region is specified in FindRoot, it finds negative solutions.

 FindRoot[f1[k, 1] - 3.4, {k, 0.2}]
{k -> -0.0924619}


which is not what I want.

In an ideal world, FindRoot would get to the end of the admissible region, acknowledge no solution was found, go back to the guess value and search in the opposite direction (I do not actually know what algorithm FindRoot uses at all).

How could I make this approach work? Actually, the fact FindRoot finds negative values could be favourable. For each $$n$$, I could fill my $$2 \times n$$ table with the solutions, and "interpret" negative solutions as an indication only one root exists in the $$(0,1)$$ interval. For example, referring to the graph above

Values@Table[FindRoot[f1[k, i] - 6, {k, 0.999}], {i, 1, 2}]
{{0.996678}, {0.710837}}


will give me the intersection "from the left", and

Values@Table[FindRoot[f1[k, i] - 6, {k, 0.0}], {i, 1, 2}]
{{-0.475222}, {0.0682733}}


starting "from the right", where the negative root tells me there is no intersection between the blue and green line in $$(0,1)$$.

Is there any more clever approach? One could in principle define for each $$n$$ and a given $$L$$ if one or two intersection are expected, but that would require computing the minimum of the function $$F_n$$. Possibly there are root finding tools better suited than FindRoot, any hint would be helpful, thanks.

• You could use FindInstance[fn[k,1]-3.4==0&&0<=k<=1,k,Reals,2] to find two instances in the region. According to the docs this should only return 1 value if there is only one solution, but running it on my machine OSX, MMA v12.0 it returns the same solution twice, but you could easily do DeleteDuplicates[k/.FindInstance[...]]. – N.J.Evans Apr 28 '20 at 20:10
• @N.J.Evans thanks I did not know about FindInstance. Regretfully I am using 11.2 and cannot try it yet. – Smerdjakov Apr 28 '20 at 23:25

NSolve will find find the roots without an initial estimate

Clear["Global*"]

fn[k_, n_] := 2*EllipticK[k]*n/((1 + k)/Sqrt[1 + k^2])

rootsk[n_?NumericQ, L_?NumericQ] :=
NSolve[{fn[k, n] == L, 0 <= k <= 1}, k]

rootsk[1, 3]

(* {{k -> 0.0682733}, {k -> 0.710837}} *)

rootsk[1, 3.4]

(* {{k -> 0.852433}} *)

rootsk[#, 6] & /@ {1, 2}

(* {{{k -> 0.996678}}, {{k -> 0.0682733}, {k -> 0.710837}}} *)


EDIT: Tabulating

Select[
table = Table[{L, n, Sequence @@ N[k /. rootsk[n, L]]},
{L, 3, 6, .25}, {n, 1, 2}] //
Flatten[#, 1] &,
FreeQ[#, k] &] //
Prepend[#,
Style[#, 14, Bold] & /@
{"L", "n", Subscript["k", 1],
Subscript["k", 2]}] & //
Grid[#, Frame -> All] &


• Thank you Sir that is excellent.. I tried NSolve but without constraints was not working. It also does a great job when roots are not found, by simply leaving empty elements. – Smerdjakov Apr 28 '20 at 22:21
• the edit is much appreciated, I am studying it carefully, thanks – Smerdjakov Apr 28 '20 at 23:30

Working with older versions of MMA, NSolve doesn't do the job, @Bob Hanlon posted.

If you want to or must work with FindRoot let me propose this solution.

f1[k_, n_] = 2*EllipticK[k]*n/((1 + k)/Sqrt[1 + k^2])

kroots[n_, L_] :=
{Check[
k /. FindRoot[(f1[k, n] - L), {k, 1 - 10^-15, 0, 1}], {}],
Check[k /. FindRoot[(f1[k, n] - L), {k, 10^-15, 0, 1}], {}]} //
Flatten // Sort // Quiet

Table[{"L" -> L, "n" -> n, kroots[n, L]}, {L, 3, 12, .25},
{n, 1, 3}] // MatrixForm


Plot[{First@kroots[3, L], Last@kroots[3, L]}, {L, 0, 20},
PlotRange -> {0, 1}, PlotPoints -> 100] // Quiet
`

• thanks for this, extremely instructive. I saw it only after accepting the first answer. – Smerdjakov May 6 '20 at 18:40