Skip to main content
2 of 3
Responded to comment
Michael E2
  • 244.8k
  • 18
  • 351
  • 774

Update: I misread the OP and counted the six distinct function for $k(x)$ as solutions. The OP was trying to solve equations of the form $k(x) = k_0$, for which I get only three solutions for $0 < k_0 < \pi$, just as expected. ContourPlot has a rather weak ability to resolve roots/curves that are close together. It detects solutions via sign changes, and to detect a pair of roots it has to sample the function between them; otherwise, there would be no sign change and ContourPlot will assume there are no solutions there.

I proposed the NDSolve method below as an alternative to ContourPlot. One can use the power of NSolve to resolve the roots, and NDSolve can trace roots throughout the domain. If preferred, one could switch the dependent and independent variables and solve for x[k] as a function of k. There is a discontinuity at k = Pi/2 and one would have to solve twice, once for each of the domains 0 < k < Pi/2 and Pi/2 < k < Pi (or one could integrate over {x, 0, 2 Pi} and use Mod[x, Pi] to construct the solutions over the lower domain.


I find six distinct solutions functions $k(x)$ for T = 1/10 at high working precision:

eq[x_, k_, T_] := -Sin[3*k + x]/Sin[2*k + x] + z + 2*Cos[k] + 
    T^2 + (A*T^2*Sin[k]^2)/(Sin[2*k + x]^2 + B*T^4*Sin[k]^2) /.
    {A -> 1/2, B -> 1/100000, z -> -237/100};
x0 = 1;
wp = 100;   (* working precision *)
k0 = k /. NSolve[{eq[x, k, 1/10] == 0 /. x -> x0, 0 < k < Pi},  (* six roots *)
    k, WorkingPrecision -> wp];
Quiet[
  ndsol = First@NDSolve[{
        D[eq[x, k[x], 1/10], x] == 0,
        k[x0] == #},
       k, {x, 0, Pi},
       PrecisionGoal -> 20, WorkingPrecision -> wp] & /@ k0,
  {Power::infy, Infinity::indet}];
k["Domain"] /. ndsol // N
(*  messages Power::infy, Infinity::indet, NDSolve::ndsz,... omitted  *)
(*  Domains of solutions:
  {{{0., 3.14159}}, {{0., 3.14159}}, {{0., 3.14159}},
   {{8.10181*10^-99, 3.14159}}, {{4.85285*10^-55, 3.14159}},
   {{7.61263*10^-99, 3.14159}}}
*)

ListLinePlot[k /. ndsol, PlotLegends -> Thread[k[x0] == N@k0], ImageSize -> Large]

enter image description here

Two pair are close to each other but distinct. For instance:

ListLinePlot[
 Table[
  eq[1, k, 1/10], {k, k0[[2]] - 1*^-7, k0[[2]] + 1*^-7, 1*^-9}], 
 GridLines -> {k0, None}, 
 DataRange -> {k0[[2]] - 1*^-7, k0[[2]] + 1*^-7}]

ListLinePlot[
 Table[
  eq[1, k, 1/10], {k, k0[[3]] - 1*^-7, k0[[3]] + 1*^-7, 1*^-9}], 
 GridLines -> {k0, None}, 
 DataRange -> {k0[[3]] - 1*^-7, k0[[3]] + 1*^-7}]

enter image description here enter image description here

Michael E2
  • 244.8k
  • 18
  • 351
  • 774