The Lorenz equations are
X dot = sigma (Y - X)	
Y dot =	-XZ + rX - Y	
Z dot = XY - bZ
We consier the standard parameters, r = 28, sigma = 10, b = 8/3.
The fixed points are (0, 0, 0), (xf, xf, 27) and (-xf, -xf, 27), 

Two functions are defined when you run the next cell.
The inputs for each function are s (best chosen between 0 and 1) and tf (the final time of the numerical integration).

The initial conditions below are chosen on the line segment between the two fixed point on the z = 27 plane:
(s xf, s xf, 27)

The fig[s, tf] command shows the Poincare map, with a dot every time the trajctory crosses the z = 27 plane going upward.

The list[s, tf] command gives a list of 1’s (for looping right) and -1’s (for looping left).

sig = 10;
r = 28;
b = 8/3;
(* You can change these constants above this line. *)

xf = Sqrt[(r-1.) b];
(* The fixed points are (0,0,0), (xf, xf, r-1), and (-xf, -xf, r-1) *)

fig[s_, tf_] := Module[{},
x0 = s* xf;  (* the intial condition *)
y0 = s* xf;
z0 = r-1;
{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];
If[poincare ≠ {}, poincare = Part[poincare, 1] ];
points = Table[{poincare[[i, 1]], poincare[[i, 2]], r-1}, {i, Length[poincare]}];
yList = Table[poincare[[i, 2]], {i, Length[poincare]}];
signList = Sign[yList];
z27plane = Graphics3D[{Opacity[0.7],Polygon[{{-25, -25, r-1}, {-25, 25, r-1}, {25, 25, r-1}, {25, -25, r-1}}], PointSize[Medium], Black, Point[{xf, xf, r-1}], Point[{-xf, -xf, r-1}],Point[{x0, y0, z0}],Red, Point[points]}];
pTrajectory =ParametricPlot3D[{x[t], y[t], z[t]}/.soln, {t, 0, tf}, PlotLabel -> "IC = (s (Subscript[x, f]), s (Subscript[x, f]), 27), with s = "<>ToString[s]];
Show[pTrajectory, z27plane]
]

list[s_, tf_] := Module[{},
x0 = s* xf;  
y0 = s* xf;
z0 = r-1;
{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];
If[poincare ≠ {}, poincare = Part[poincare, 1] ];
points = Table[{poincare[[i, 1]], poincare[[i, 2]], r-1}, {i, Length[poincare]}];
yList = Table[poincare[[i, 2]], {i, Length[poincare]}];
signList = Sign[yList]
]

Now that these functions are defined, you can run the functions. 
The parameters are
* s between -1 and 1 to give the inial condition
 * tf, or t-final.  You can make this quite large, although the figure looks best with moderate tf.
 
 Note:  If you are doing statistics on the list of L’s and R’s (-1s and 1s) with a random s between 0 and 1 (s = Random[]), then disregard the initial string of repeated 1s.  Using this random s is biased towards having many 1s in a row.

fig[.2,4]
list[.2, 4]
list[Random[], 100]