2
$\begingroup$

I am trying to plot the effective potential of massive particles with the help of this Mathematica code:

f[r_] := 1 - (2*M)/r + Q^2/r^2 + r^2/l^2;
M = (rp/2)*(1 + Q^2/rp^2 + rp^2/l^2);
L = 20.0;
Subscript[V, eff][r_] := f[r]*(L^2/r^2 + \[Delta]1);
\[Delta]1 = 0.0;
l = 1.0;
Q = 0.11;
A1 = Block[{rp = 0.11}, Plot[Subscript[V, eff][r], {r, 0, 1.}, PlotStyle -> Red]]
A2 = Block[{rp = 0.2}, Plot[Subscript[V, eff][r], {r, 0, 1.}, 
    PlotStyle -> Darker[Green], PlotRange -> {Automatic, {-3000, 3500}}]]
A3 = Block[{rp = 0.4}, Plot[Subscript[V, eff][r], {r, 0, 1.}, PlotStyle -> Blue]]
Show[{A1, A2, A3}, PlotRange -> {Automatic, {-3000, 3000}}, ImageSize -> 800]

I wish to add vertical dashed lines and use black dots representing the maxima of the effective potentials as given in the below figure, in my plot:

Effective Potential

$\endgroup$

2 Answers 2

4
$\begingroup$
Clear["Global`*"]

f[r_] := 1 - (2*M)/r + Q^2/r^2 + r^2/l^2;
M = (rp/2)*(1 + Q^2/rp^2 + rp^2/l^2);
L = 20;
Subscript[V, eff][r_] := f[r]*(L^2/r^2 + δ1);
δ1 = 0;
l = 1;
Q = 11/100;

max[rp_] = Assuming[r > rp > 0,
   Maximize[{Subscript[V, eff][r], r > rp > 0}, r] // Simplify];

Plot[Evaluate@
  Table[Subscript[V, eff][r], {rp, {11/100, 1/5, 2/5}}], {r, 0, 1},
 PlotStyle -> {Red, Darker[Green], Blue},
 PlotRange -> {{0.07, 1}, {-3000, 3000}},
 ImageSize -> 500,
 AxesLabel -> {r, Subscript[V, eff]},
 Epilog -> {Dashed,
   Red, InfiniteLine[
    {{0.11, 0}, {0.11, 1}}],
   Darker[Green], InfiniteLine[
    {{0.2, 0}, {0.2, 1}}],
   Blue, InfiniteLine[
    {{0.4, 0}, {0.4, 1}}],
   Black, AbsolutePointSize[4],
   Point[({r, Subscript[V, eff][r]} /.
        {rp -> #, max[#][[2, 1]]}) & /@
     {0.11, 0.2, 0.4}]},
 PlotLegends -> Placed[
   (StringForm["``=``", Subscript[r, "+"], NumberForm[#, {5, 2}]] & /@
     {0.11, 0.2, 0.4}), {0.85, 0.25}]]

enter image description here

$\endgroup$
0
3
$\begingroup$
Clear["Global`*"]
f[r_] := 1 - (2*M)/r + Q^2/r^2 + r^2/l^2;
M = (rp/2)*(1 + Q^2/rp^2 + rp^2/l^2);
L = 20.0;
Subscript[V, eff][r_] := f[r]*(L^2/r^2 + \[Delta]1);
\[Delta]1 = 0.0;
l = 1.0;
Q = 0.11;

{m1, m2, m3} = 
 NMaximize[{Subscript[V, eff][r], r > 0.1}, r] /. rp -> # & /@ {0.11, 
    0.2, 0.4} // Quiet
pts = {First@Values@Last@#, First@#} & /@ {m1, m2, m3}

Plot[Evaluate[
  Subscript[V, eff][r] /. rp -> # & /@ {0.11, 0.2, 0.4}
  ]
 , {r, 0, 1.}
 , PlotStyle -> {Red, Darker@Green, Blue},
 Epilog -> {
   AbsolutePointSize[5], Black, Point /@ pts
   , Dashed, Transpose[{{Red, Darker@Green, Blue}
     , Map[InfiniteLine,
      {{#, 0}, {#, 1}} & /@ {0.11, 0.2, 0.4}, {1}]}]
   , Text[Last@#, # + {0, 140}] & /@ pts
   }
 , PlotLegends -> Placed[
   LineLegend[{Red, Darker@Green, Blue}, "r+ = " <> 
       ToString[NumberForm[#, {5, 2}]] & /@ {0.11, 0.2, 0.4}
    ], {0.8, 0.14}
   ]
 , ImageSize -> Large
 ]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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