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

Question

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:

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!

Answer 1

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

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

The plot in the paper has normalized parameters.