# Finding data of intersection points for a moving line and a curve from a parametric plot

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 = {#[], \[Lambda][Qt, rpt1 = (rpt /. #[])]} &@
Maximize[{Tt[rpt], 1/16 < rpt < 1}, rpt] // FullSimplify) // N;
(tp2 = {#[], \[Lambda][Qt, rpt2 = (rpt /. #[])]} &@
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[], 0}}],
InfiniteLine[{tp2, {tp2[], 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: 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!

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}] Plot[Δλ[Qt, t], {t, 0.27, 0.33},
AxesLabel -> {T, Δλ}] The plot in the paper has normalized parameters.

• For the same code, I am getting a different result: imgur.com/y6Zu9kB, not sure why? Sep 8, 2022 at 6:28
• I must have had an \$Assumption left over from earlier work. Just constrain the SolveValues with rpt > 0 Sep 8, 2022 at 13:04
• 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 :) Sep 8, 2022 at 14:57