0
$\begingroup$

I have the following Mathematica code to generate the plot of Lyapunov exponents v/s Temperature:

T[rp_] := 1/(4 \[Pi] rp) (1 - Q^2/rp^2 + (3 rp^2)/l^2)
M[rp_] := rp/2 (1 + Q^2/rp^2 + rp^2/l^2)
S[rp_] := \[Pi] rp^2
\[Phi][rp_] := Q/rp
F[rp_] := Simplify[M[rp] - (T[rp] S[rp])]
Q = Qt l;
rp = rpt l;
Tt[rpt_] = T[rp] l;
Ft[rpt_] = F[rp]/l;
Mt[rpt_] = M[rp]/l;
r = rt l;
f[r_] := 1 - (2 Mt[rpt])/r + Q^2/r^2 + r^2/l^2
Veff[rt_] = f[r] (L^2/r^2 + \[Delta]1);
r0 = l/2 (3/2 rpt (Qt^2/rpt^2 + rpt^2 + 1) + Sqrt[
     9/4 rpt^2 (Qt^2/rpt^2 + rpt^2 + 1)^2 - 8 Qt^2]);
l = 1; \[Delta]1 = 0;
\[Lambda][Qt_, rpt_] = 
  Sqrt[-((r0^2 f[r0])/L^2) Veff''[r0]] // Simplify;
Qt = 11/100;
(tp1 = {#[[1]], \[Lambda][Qt, rpt1 = (rpt /. #[[2]])]} &@
      Maximize[{Tt[rpt], 1/16 < rpt < 1}, rpt] // FullSimplify) // N;
(tp2 = {#[[1]], \[Lambda][Qt, rpt2 = (rpt /. #[[2]])]} &@
      Minimize[{Tt[rpt], rpt1 < rpt < 1}, rpt] // FullSimplify) // N;
pplt1 = ParametricPlot[{Tt[rpt], \[Lambda][Qt, rpt]}, {rpt, 0.01, 2}, 
   PlotRange -> {{0.2, 0.34}, {0.75, 3.00}}, AspectRatio -> 1, 
   AxesLabel -> {"T", "\[Lambda]"}, 
   ColorFunction -> 
    Function[{Tt, \[Lambda]t, rpt}, 
     If[rpt <= rpt1, Blue, If[rpt <= rpt2, Red, Green]]], 
   ColorFunctionScaling -> False];

Legended[Show[pplt1, 
  Graphics[{Dotted, InfiniteLine[{tp1, {tp1[[1]], 0}}], 
    InfiniteLine[{tp2, {tp2[[1]], 0}}], Dashed, 
    InfiniteLine[{0.2803, 0.0}, {0.0, 0.001}]}], 
  PlotRange -> {{0.2, 0.34}, {0.75, 3.00}}, 
  AxesOrigin -> {0.2, 0.75}], 
 Placed[LineLegend[{Blue, Green, Red}, {"Small BH", "Large BH", 
    "Intermediate BH"}], {.3, .5}]]

which gives me the following output:
lambda v/s T
I desire a table of $\Delta \lambda$ v/s $T$ for which I need the data of intersection points on the Small BH(blue curve) and the Large BH(green curve), excluding the Intermediate BH(red curve) made by the infinite dashed line on the curve moving in the range of tp1 to tp2, to get the desired figure 4 in the reference paper (page 7).
Any help in this regard would be truly beneficial!

$\endgroup$

1 Answer 1

3
$\begingroup$

Using your function definitions,

Clear[Δλ]

EDIT: Add constraint rpt > 0

Δλ[Qt_?NumericQ, t_?NumericQ] := 
 Subtract @@ (λ[Qt, #] & /@
    MinMax[SolveValues[{Tt[rpt] == t, rpt > 0}, rpt, Reals]])

NumberForm[
 Prepend[
   Table[{t, Δλ[Qt, t]} // N, {t, 0.27, 0.33, 0.005}],
   {T, Δλ}] //
  Grid[#, Frame -> All] &,
 {5, 3}]

enter image description here

Plot[Δλ[Qt, t], {t, 0.27, 0.33},
 AxesLabel -> {T, Δλ}]

enter image description here

The plot in the paper has normalized parameters.

$\endgroup$
3
  • $\begingroup$ For the same code, I am getting a different result: imgur.com/y6Zu9kB, not sure why? $\endgroup$
    – codebpr
    Sep 8, 2022 at 6:28
  • $\begingroup$ I must have had an $Assumption left over from earlier work. Just constrain the SolveValues with rpt > 0 $\endgroup$
    – Bob Hanlon
    Sep 8, 2022 at 13:04
  • $\begingroup$ Now I am getting the same plot as yours. When I use normalized parameters, I am not getting Figure 4(left). Maybe we need to vary Qt, which means a different plot for each value of Qt, till Qt=Qc (critical value), and then calculate the difference. I guess I should ask a different Question for that problem. Thank you for the much needed help :) $\endgroup$
    – codebpr
    Sep 8, 2022 at 14:57

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.