0
$\begingroup$

I am practicing solving the following transcendental equation in Mathematica:

(a/c)*Sqrt[(b*m1)^2-(p*c)^2]-ArcTan[Sqrt[((p*c)^2-(b*m2)^2)/((b*m1)^2-(p*c)^2)]]-
  ArcTan[Sqrt[((p*c)^2-(b*m3)^2)/((b*m1)^2-(p*c)^2)]] == r*Pi

here

a=1x10^-6; c= 3x10^8; m1=2.2; m2=1.5; m3=1;

I was trying to plot "p" vs "b" where "b" runs from 0 to 3x10^15 and r is a parameter that takes values of 0, 1 and 2. I already tried all day but I cannot find solution, I tried with FindRoot without success, can you give any suggestion?

$\endgroup$
3
$\begingroup$
a = 10^-6; c = 3*^8; m1 = 11/5; m2 = 3/2; m3 = 1;

eqn = (a/c)*Sqrt[(b*m1)^2 - (p*c)^2] -
    ArcTan[Sqrt[((p*c)^2 - (b*m2)^2)/((b*m1)^2 - (p*c)^2)]] -
    ArcTan[Sqrt[((p*c)^2 - (b*m3)^2)/((b*m1)^2 - (p*c)^2)]] == r*Pi;

EDIT: To find the function domain (i.e., LHS of eqn is real)

fd = Reduce[FunctionDomain[{eqn[[1]], b >= 0, p >= 0}, {b, p}], {b, p}]

(* b > 0 && b/200000000 <= p < (11 b)/1500000000 *)

Show[RegionPlot[fd, {b, 0, 3*^15}, {p, 10^5, 10^7}, 
  PlotStyle -> Opacity[0.1], BoundaryStyle -> None], 
 ContourPlot[
  Evaluate@Table[eqn, {r, 0, 2}], {b, 0, 3*^15}, {p, 10^5, 10^7}, 
  PlotLegends -> 
   Placed[StringForm["r = ``", #] & /@ Range[0, 2], {0.75, 0.25}]], 
 FrameLabel -> (Style[#, 14, Bold] & /@ {b, p})]

enter image description here

There are an infinite number of {b, p} values on each curve (i.e., for each value of r). Select a value of b then select an initial value for p for use in FindRoot

FindRoot[eqn /. { r -> 0, b -> 10^15}, {p, 6*^6}]

(* {p -> 6.95393*10^6} *)

FindRoot[eqn /. { r -> 1, b -> 12*^14}, {p, 7*^6}]

(* {p -> 7.38373*10^6} *)

FindRoot[eqn /. { r -> 2, b -> 18*^14}, {p, 10^7}]

(* {p -> 1.06722*10^7} *)

EDIT 2: Example for r = 0. Define pEst[b] for estimate of p in FindRoot

pEst[b_] = 
  s*b + i /. 
   FindFit[{{2*^14, 
      p /. FindRoot[eqn /. {r -> 0, b -> 2*^14}, {p, 10^6}, 
        WorkingPrecision -> 20]}, {13*^14, 
      p /. FindRoot[eqn /. {r -> 0, b -> 13*^14}, {p, 95*^5},
        WorkingPrecision -> 20]}}, s*b + i, {s, i}, b];

Generate data for ListLinePlot

data = Table[{b, p /. FindRoot[eqn /. r -> 0, {p, pEst[b]},
      WorkingPrecision -> 20]}, {b, 2*^14, 15*^14, 10^14}] // N

(* {{2.*10^14, 1.05947*10^6}, {3.*10^14, 1.72713*10^6}, {4.*10^14, 
  2.44625*10^6}, {5.*10^14, 3.18773*10^6}, {6.*10^14, 
  3.93841*10^6}, {7.*10^14, 4.6924*10^6}, {8.*10^14, 5.44702*10^6}, {9.*10^14,
   6.20104*10^6}, {1.*10^15, 6.95393*10^6}, {1.1*10^15, 
  7.70553*10^6}, {1.2*10^15, 8.45578*10^6}, {1.3*10^15, 
  9.20476*10^6}, {1.4*10^15, 9.95254*10^6}, {1.5*10^15, 1.06992*10^7}} *)

Plot the data

ListLinePlot[data,
 Frame -> True, Axes -> False,
 PlotRange -> {{0, 3*^15}, {0, 10^7}},
 AspectRatio -> 1,
 FrameLabel -> (Style[#, 14, Bold] & /@ {b, p})]

enter image description here

However, using ContourPlot as shown earlier is more straightforward.

$\endgroup$
  • $\begingroup$ why the line solutions are discontinues? because I compare your plot with the reported solution and all are continues and begin on zero $\endgroup$ – yhiel Jun 13 '18 at 11:13
  • $\begingroup$ @yhiel - See edit. Verify your equation and/or reported solution. $\endgroup$ – Bob Hanlon Jun 13 '18 at 15:31
  • $\begingroup$ I see my mistake you are right, but I have a dout I trying to solve this with FindRoot Table[FindRoot[Eqn] and obtain all values for b and create a list to plotting $\endgroup$ – yhiel Jun 15 '18 at 0:46

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.