Now, find one more solution. But put this in a different place!

t0Plot = 0.95;
tfPlot = 1.429; (* when it hits z = 27 going up *)
sig = 10;
r = 28;
b = 8/3;
xf = Sqrt[(r-1.) b]; (* x and y coordinate of the nontrivial fixed points *)
zf = r-1;
theta = 1.2;
ct = Cos[theta];
st = Sin[theta];
ss =.183; (* sR0p = 0.170890444 This was found in LorenzFindStableManifold.nb*)
x0 = ss* xf;  
y0 = ss* xf;
z0 = r-1;
tf = 1.8;
{peelSoln,poincare}=Reap@NDSolve[{
x'[t]==sig(y[t]-x[t]),
y'[t]==r x[t]-y[t]- x[t] z[t], 
z'[t] == x[t] y[t] - b z[t],
x[0]== x0,y[0]==y0,z[0] == z0, 
WhenEvent[z[t] == 27, Sow[{x[t],y[t], t}] ]},
{x,y, z},{t,0,tf}];
peelSoln = Part[peelSoln, 1]; (* the one and only numerical solution *)
Print["Last point is ",{ct x[tfPlot]+st y[tfPlot], z[tfPlot]}/.peelSoln];
poincare = Part[poincare, 1]; (* List of (x, y, t) triplets every time z = 27 *)
tList = Transpose[poincare][[3]]
figPeelRight =ParametricPlot[{ct x[t]+st y[t], z[t]}/.peelSoln, {t, t0Plot,tfPlot}, PlotStyle -> Black,PlotRange ->All];
figArrowRight = Graphics[Polygon[{{25.83, 26},{27.23,26},{26.63,27.5}}]];
figPeelLeft =ParametricPlot[{-ct x[t]-st y[t], z[t]}/.peelSoln, {t, t0Plot,tfPlot}, PlotStyle -> Black,PlotRange ->All];
figArrowRight = Graphics[Polygon[{{25.83, 26},{27.23,26},{26.63,28}}]];
figArrowRLeft = Graphics[Polygon[{{-25.83, 26},{-27.23,26},{-26.63,28}}]];
Show[figPeelRight, figArrowRight]

sig = 10;
r = 28;
b = 8/3;
xf = Sqrt[(r-1.) b]; (* x and y coordinate of the nontrivial fixed points *)
zf = r-1;
theta = 1.2;
ct = Cos[theta];
st = Sin[theta];
ss =sRRRRR0p = 0.474788474; (* This was found at the end of LorenzFindStableManifold.nb*)
x0 = ss* xf;  
y0 = ss* xf;
z0 = r-1;
tf = 20;
{soln,poincare}=Reap@NDSolve[{
x'[t]==sig(y[t]-x[t]),
y'[t]==r x[t]-y[t]- x[t] z[t], 
z'[t] == x[t] y[t] - b z[t],
x[0]== x0,y[0]==y0,z[0] == z0, 
WhenEvent[z[t] == 27, Sow[{x[t],y[t], t}] ]},
{x,y, z},{t,0,tf}];
soln = Part[soln, 1]; (* the one and only numerical solution *)
poincare = Part[poincare, 1]; (* List of (x, y, t) triplets every time z = 27 *)
tList = Transpose[poincare][[3]]
figSandU =ParametricPlot[{ct x[t]+st y[t], z[t]}/.soln, {t, 0, tf}, PlotRange -> All, PlotStyle -> Black]

tStart =0.37293250763554847;   (* not on attractor at t = 0, so give it half a turn *)
tLand =5.87629389010842`; (* time it lands and starts loopin around the left eye *)
tJoin = 17.4491574541667`; (* Time when the reflected looping almost joints start *)
pOuter =ParametricPlot[{ct x[t]+st y[t], z[t]}/.soln, {t, tStart, tLand}, PlotRange -> All, PlotStyle -> Black];
pInner =ParametricPlot[{-ct x[t]-st y[t], z[t]}/.soln, {t,tLand, tJoin}, PlotRange -> All, PlotStyle -> Black];pBranch = ParametricPlot[{ct s xf+ st s xf, 27}, {s, -0.85,0}, PlotStyle -> {Dotted,LightGray}];
pRightWingSimple = Show[pOuter, pInner,pBranch,  figPeelOff,Axes -> False];
pRightWing = Show[pOuter, pBranch, pOuter,pInner,figPeelRight, figArrowRight,Axes -> False]

tStart =0.37293250763554847; 
tLand =5.87629389010842`;
tJoin = 17.4491574541667`;
pOuter =ParametricPlot[{-ct x[t]-st y[t], z[t]}/.soln, {t, tStart, tLand}, PlotRange -> All, PlotStyle -> Black];
pInner =ParametricPlot[{ct x[t]+st y[t], z[t]}/.soln, {t,tLand, tJoin}, PlotRange -> All, PlotStyle -> Black];pBranch = ParametricPlot[{ct s xf+ st s xf, 27}, {s, 0,0.85}, PlotStyle -> {Dotted, LightGray}];
pLeftWingSimple = Show[pOuter, pInner,pBranch,  Axes -> False];
pLeftWing = Show[pOuter, pBranch, pOuter,pInner, figPeelLeft, figArrowRLeft ,Axes -> False]

Show[pRightWing, pLeftWing]

onePair = GraphicsRow[{pLeftWing,pRightWing}]

twoPair = GraphicsGrid[{{pLeftWing,pRightWing},{pLeftWing,pRightWing}}]

Export["C:\\Users\\jws8\\Dropbox\\classes\\MAT 667 2025.1\\LorenzSnail.pdf", twoPair]

Export["C:\\Users\\jws8\\Dropbox\\classes\\MAT 667 2025.1\\LorenzStableAndUnstable.png", figSandU, ImageSize -> 300]

Export["C:\\Users\\jws8\\Dropbox\\classes\\MAT 667 2025.1\\LorenzStableAndUnstable.pdf", figSandU]