Solve transcendental equation and plot the roots

Question

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?

Answer 1

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

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

However, using ContourPlot as shown earlier is more straightforward.