Solving a transcendental equation with FindRoot and making a contour plot

Question

I have the following functions,

f[Cpl_, a_, EF_, V_, Jsd_, α_, β_, σ_, ϕ_][kp_] := 
  With[{kx = kp*Cos[σ], ky = kp*Sin[σ]},
    With[
      {θ = 
         ϕ - 
           If[α*kx >= 0, 
              ArcCos[β*ky/Sqrt[(α*kx)^2 + (β*ky)^2]], 
              2*Pi - ArcCos[β*ky/Sqrt[(α*kx)^2 + (β*ky)^2]]],
       kzdo = Sqrt[Cpl*(EF + (Jsd/2)) - kx^2 - ky^2],
       kzup = Sqrt[Cpl*(EF - (Jsd/2)) - kx^2 - ky^2],
       Qp = 
         Sqrt[Cpl*(V - EF + Sqrt[(α*kx)^2 + (β*ky)^2]) + kx^2 + ky^2],
       Qm = 
         Sqrt[Cpl*(V - EF - Sqrt[(α*kx)^2 + (α*ky)^2]) + kx^2 + ky^2]
      },
      4*
        (Sin[a*kzdo]*
          (kzup*(Qm + Qp + (Qm - Qp)*Cos[θ])*Cos[a*kzup] + 2*Qm*Qp*Sin[a*kzup]) +
        kzdo*Cos[a*kzdo]*(2*kzup*Cos[a*kzup] + 
          (Qm + Qp - (Qm - Qp)*Cos[θ])*Sin[a*kzup]))^2]];

and then I fix all variables except three of them,

CPl1 = 0.262227; 
a1 = 5.0000000000; 
EF1 = 2.600000000; 
V1 = EF1 + 0.500000000000; 
Jsd1 = 1.50000000000; 
ϕ1 = Pi/12; 
α1 = 1.0; 
β1 = 1.0;

function[En_, σ_][kp_] := f[CPl1, a1, En, En + 0.5, Jsd1, α1, β1, σ, ϕ1][kp]

I would like to solve this equation for fixed values of En & σ for kp. Function NSolve does not work, so I use FindRoot function. To use it, I plot my function using Plot and deduce where roots are "located" (careful analysis of regions says that there are 4 roots):

For instance, fixing E=3.0 and σ=0 method FindRoot gives me 4 roots.

Then, I chek my results. I plot implicit function function=0 using ContourPlot:

It is clearly only two roots. I know that ContourPlot sometimes gives inaccurate plots and it can be fixed by plotting $\text{function}=\epsilon$, where, for instance, $\epsilon\sim 10^{-8}$. However, it does not solve my problem.

Accuracy of FindRoot says that value function is about $\sim 10^{-11}-10^{-14}$ in every root. I do not understand what is wrong with my code. How should I deal with this problem?

Answer 1

The primary issue in this question is plotting resolution. Both Plot and ContourPlot sample the function to be plotted at a finite number of locations. If none of these locations is sufficiently near a portion of the desired curve, then that portion may be missed. In this case, greatly increasing PlotPoints and setting MaxRecursion yields,

Plot[function[3, 0][kp], {kp, 0, 1}, PlotRange -> {-1, 1}, 
    PlotPoints -> 400000, MaxRecursion -> 5, ImageSize -> Large, 
    AxesLabel -> {kp, fun}, LabelStyle -> {15, Bold, Black}]

Distinct roots are seen to occur at about 0.58, 0.77, 0.84, and 0.99. Because the curve at 0.58 is tangent to the axis from above, ContourPlot is unlikely to find it unless function is equated to some small positive number. Likewise, because the curve at 0.84 is tangent to the axis from below, ContourPlot is unlikely to find it unless function is equated to some small negative number. The following finds both.

pltp = ContourPlot[function[En, 0][kp] == 10^-4, {En, 0, 4}, {kp, 0, 1}, 
    PlotPoints -> 250, MaxRecursion -> 3, ImageSize -> Large, 
    LabelStyle -> {15, Bold, Black}, FrameLabel -> {En, kp}];
pltm = ContourPlot[function[En, 0][kp] == -10^-4, {En, 0, 4}, {kp, 0, 1}, 
    PlotPoints -> 250, MaxRecursion -> 4, ImageSize -> Large, 
    LabelStyle -> {15, Bold, Black}, FrameLabel -> {En, kp}]
Show[pltp, pltm]

A vertical slice through the ContourPlot at En = 3 exhibits the same four roots as in the first plot. The fifth curve does not intersect En = 3 and, therefore, is not a root of the curve in the first plot.