4
$\begingroup$

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):

enter image description here

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: enter image description here

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?

$\endgroup$

1 Answer 1

7
$\begingroup$

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}]

enter image description here

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]

enter image description here

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.

$\endgroup$
1
  • $\begingroup$ Comprehensive & clear. Thank you! $\endgroup$ Dec 29, 2019 at 8:45

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.