Aleksandr Mikhailovich Lyapunov (1857-1918)

Liapunov Exponent for Lorenz Equations

f[x_,y_,z_,σ_]:=σ(y-x);
g[x_,y_,z_,r_]:=r x-y-x z;
h[x_,y_,z_,b_]:=x y-b z;

r=20;b=1;σ=10;
d=.0001;
x0=10;y0=10;z0=10;
T=100;
sola=NDSolve[{x'[t]==f[x[t],y[t],z[t],σ],y'[t]==g[x[t],y[t],z[t],r],z'[t]==h[x[t],y[t],z[t],b],x[0]==x0,y[0]==y0,z[0]==z0},{x[t],y[t],z[t]},{t,0,T}];
solb=NDSolve[{x'[t]==f[x[t],y[t],z[t],σ],y'[t]==g[x[t],y[t],z[t],r],z'[t]==h[x[t],y[t],z[t],b],x[0]==x0,y[0]==y0,z[0]==z0+d},{x[t],y[t],z[t]},{t,0,T}];
Show[ParametricPlot3D[{x[t],y[t],z[t]}/.sola,{t,0,T},PlotStyle->Blue],Graphics3D[{{Blue,Sphere[{x0,y0,z0},.2]}}],ParametricPlot3D[{x[t],y[t],z[t]}/.solb,{t,0,T},PlotStyle->Red],Graphics3D[{{Red,Sphere[{x0,y0,z0+d},.2]}}],PlotRange->All]
Plot[Log[Norm[({x[t],y[t],z[t]}/.solb)-({x[t],y[t],z[t]}/.sola)]],{t,0,T},PlotStyle->{Black,Thickness[.002]}]

Plot[Log[Norm[({x[t],y[t],z[t]}/.solb)-({x[t],y[t],z[t]}/.sola)]],{t,10,30},PlotStyle->{Black,Thickness[.002]}]

LinearFit=Fit[Table[{t,Log[Norm[({x[t],y[t],z[t]}/.solb)-({x[t],y[t],z[t]}/.sola)]]},{t,10,30,.01}],{1,t},t]

Plot[{LinearFit,Log[Norm[({x[t],y[t],z[t]}/.solb)-({x[t],y[t],z[t]}/.sola)]]},{t,0,50},PlotStyle->{{Black,Thickness[.002]},{Blue,Thickness[.002]}}]

Rough estimate of largest Liapunov exponent for this set of parameter values : λ = 0.46.

r=20;b=1;σ=10;
d=.0000001;
x0=10;y0=-10;z0=-20;
T=100;
sola=NDSolve[{x'[t]==f[x[t],y[t],z[t],σ],y'[t]==g[x[t],y[t],z[t],r],z'[t]==h[x[t],y[t],z[t],b],x[0]==x0,y[0]==y0,z[0]==z0},{x[t],y[t],z[t]},{t,0,T}];
solb=NDSolve[{x'[t]==f[x[t],y[t],z[t],σ],y'[t]==g[x[t],y[t],z[t],r],z'[t]==h[x[t],y[t],z[t],b],x[0]==x0,y[0]==y0,z[0]==z0+d},{x[t],y[t],z[t]},{t,0,T}];
Show[ParametricPlot3D[{x[t],y[t],z[t]}/.sola,{t,0,T},PlotStyle->Blue],Graphics3D[{{Blue,Sphere[{x0,y0,z0},.2]}}],ParametricPlot3D[{x[t],y[t],z[t]}/.solb,{t,0,T},PlotStyle->Red],Graphics3D[{{Red,Sphere[{x0,y0,z0+d},.2]}}],PlotRange->All]
Plot[Log[Norm[({x[t],y[t],z[t]}/.solb)-({x[t],y[t],z[t]}/.sola)]],{t,0,T},PlotStyle->{Black,Thickness[.002]}]

Plot[Log[Norm[({x[t],y[t],z[t]}/.solb)-({x[t],y[t],z[t]}/.sola)]],{t,16,43},PlotStyle->{Black,Thickness[.002]}]

LinearFit=Fit[Table[{t,Log[Norm[({x[t],y[t],z[t]}/.solb)-({x[t],y[t],z[t]}/.sola)]]},{t,16,43,.01}],{1,t},t]

Plot[{LinearFit,Log[Norm[({x[t],y[t],z[t]}/.solb)-({x[t],y[t],z[t]}/.sola)]]},{t,0,50},PlotStyle->{{Black,Thickness[.002]},{Blue,Thickness[.002]}}]

Rough estimate of largest Liapunov exponent for this set of parameter values : λ = 0.44.