4
$\begingroup$

There is a system of differential equations:

enter image description here

Then, call the limit cycle the projection of the phase trajectory onto the plane in a pairwise combination of state variables ($x-y,y-z,x-z$).

where $x,y,z$ - state variables, $a,b,c$ - constants.

Is it possible to use Mathematica to estimate the amplitude and frequency of the limit cycle? (it is possible by approximate numerical methods, most importantly, not graphical).

I did like this: 1. Using NDSolve, I solve the system of differential equations numerically.

s = NDSolve[{x'[t] == -3 (x[t] - y[t]), 
   y'[t] == -x[t] z[t] + 26.5 x[t] - y[t], z'[t] == x[t] y[t] - z[t], 
   x[0] == z[0] == 0.1, y[0] == 0.25}, {x, y, z}, {t, 0, 400}]
  1. Using ParametricPlot, I build a phase plane for a pairwise combination of state variables (see Figure 1 for an $x-y$ pair).

    ParametricPlot[Evaluate[{x[t], y[t]} /. First[%]], {t, 0, 100}]

  2. Using the Plot command, I build a graph for the state variable in time and try to estimate the frequency of the alternating signal from the graph. (see Figure 1 for an $x$ variable).

    Plot[Evaluate[x[t] /. s], {t, 0, 100}]

Figure 1

Figure 2

EDIT:

After several hours of calculations and on the advice of one of the users, I applied data sampling and Fourier expansion with the construction of a frequency spectrum.

xsol[t_] := x[t] /. s[[1]]

xdis = Table[xsol[i], {i, 0, 100, 0.1}];

ListPlot[xdis]

fft = Fourier[xdis, FourierParameters -> {1, -1}];

ListLinePlot[shortFFT = Abs[fft[[5 ;; 400]]], PlotRange -> All]

enter image description here

f = Abs[Fourier[xdis]];

peaksize = Last[TakeLargest[f, 2]];

peaks = Flatten[Position[f, i_ /; i >= peaksize]];

pos = First[peaks];

Show[ListPlot[f], Graphics[{Red, Point[{pos, f[[pos]]}]}], 
 PlotRange -> All]

n = 100/0.1 + 1;

fr = Abs[Fourier[xdis Exp[2 Pi I (pos - 2) N[Range[0, n - 1]]/n], 
    FourierParameters -> {0, 2/n}]];

frpos = Position[fr, Max[fr]][[1, 1]]

Show[ListPlot[fr], Graphics[{Red, Point[{frpos, fr[[frpos]]}]}], 
 PlotRange -> All]

N[n/(pos - 2 + 2 (frpos - 1)/n)]

Fourier - > Applications - > Frequency Identification

This code gives an estimate of a period of ~ 564 sec and a frequency of 1 / T ~ 0.002 Hz. Which, of course, does not look like the results of NDSolve.

EDIT №2:

There is my code for Lorenz System. Nothing unusual, only classical continuous Fourier series.

In[49]:= pars = {n = 15, T = 20, \[Omega] = 2 Pi/T}

Out[49]= {15, 20, \[Pi]/10}

In[61]:= s = 
 NDSolve[{x'[t] == -3 (x[t] - y[t]), 
   y'[t] == -x[t] z[t] + 26.5 x[t] - y[t], z'[t] == x[t] y[t] - z[t], 
   x[0] == z[0] == 0.1, y[0] == 0.25}, {x, y, z}, {t, 0, 20}]

In[66]:= Plot[Evaluate[x[t] /. s], {t, 0, T}, PlotRange -> Full]

In[67]:= ifun = First[x /. s]

In[68]:= a0 = 2/T NIntegrate[ifun[t], {t, 0, T}]

Out[68]= -4.74859

In[69]:= f = 
  a0/2 + Sum[
    2/T NIntegrate[
       ifun[t] Cos[\[Omega] k t], {t, 0, T}] Cos[\[Omega] k t] + 
     2/T NIntegrate[
       ifun[t] Sin[\[Omega] k t], {t, 0, T}] Sin[\[Omega] k t], {k, 1,
      n}];

In[70]:= Plot[{ifun[t], f}, {t, 0, T}, PlotRange -> Full]

QUESTION: Is it possible to speed up this code, for example, apply a faster algorithm of numerical integration?

$\endgroup$
9
  • $\begingroup$ Probably. What have you tried? $\endgroup$ – MarcoB May 26 '20 at 16:40
  • $\begingroup$ Include the code you used with NDSolve etc. If you give people something to start from, they are much more likely to help. If you have a starting point, even just the equations formatted in MMA format rather than having to type them back in, please share it by editing the question. In this case, please share the NDSolve and the ParametricPlot, together with any definition of constants you used, etc. $\endgroup$ – MarcoB May 26 '20 at 18:03
  • $\begingroup$ As you can see, I did it "manually." This is not very convenient and most likely not correct. And I do not know how to evaluate the parameters of limit cycles in Mathematica. $\endgroup$ – dtn May 27 '20 at 4:25
  • $\begingroup$ Interesting question. Perhaps Fourier on a (large) discrete equi-spaced sample set might be useful here? $\endgroup$ – Daniel Lichtblau May 27 '20 at 16:03
  • $\begingroup$ Do you mean to expand the data from NDSolve in a discrete Fourier series and analyze them? $\endgroup$ – dtn May 27 '20 at 16:11
8
$\begingroup$

These aren't actual limit cycles and what you're looking for has a fuzzy definition (notice how the amplitude increases in each pass). However this is still fun to play with, so let's see what we can find. I learned a lot of theory and practical tips from reading The Lorenz Equations: Bifurcations, Chaos, and Strange Attractors by Colin Sparrow.

Although this isn't an ecological model, my EcoEvo package has some functions that are useful, so I'll make use of it. To install it, use:

PacletInstall["EcoEvo", "Site" -> "http://raw.githubusercontent.com/cklausme/EcoEvo/master"]

Load the package and define the model:

<<EcoEvo`;

SetModel[{
  Aux[x] -> {Equation :> σ (y[t] - x[t])},
  Aux[y] -> {Equation :> r x[t] - y[t] - x[t] z[t]},
  Aux[z] -> {Equation :> x[t] y[t] - b z[t]}
}]

σ = 3;
r = 26.5;
b = 1;

First, simulate for 400 time steps to get on the attractor:

s = EcoSim[{x -> 0.1, y -> 0.25, z -> 0.1}, 400];
PlotDynamics[FinalSlice[s, 100], x]

Mathematica graphics

There are three equilibria. Find them and plot with the attractor in phase space:

eq = SolveEcoEq[]
(* {{x -> 0, y -> 0, z -> 0}, {x -> -5.04975, y -> -5.04975, z -> 25.5},
  {x -> 5.04975, y -> 5.04975, z -> 25.5}} *)

Show[
 RuleListPlot[eq[[2 ;; 3]]],
 RuleListPlot[FinalSlice[s, 100], PlotPoints -> 200]
]

Mathematica graphics

To get an approximate idea of the "period" in each wing, we could find the eigenvalues of the equilibria and calculate from their imaginary parts.

EcoEigenvalues[eq[[2]]]
(* {0.0495488 + 5.47749 I, 0.0495488 - 5.47749 I, -5.0991} *)

2 π/5.477486069462778`
(* 1.14709 *)

Looks reasonable at least!

Now for the fun part. There are a bunch of periodic orbits in there, but they're all unstable. To find them, we'll first make a Poincaré section at z = r - 1 using WhenEvent.

ps = Reap[
  EcoSim[{x -> 0.1, y -> 0.25, z -> 0.1}, 10000, 
     WhenEvents -> {WhenEvent[z[t] < r - 1, Sow[{t, x[t], y[t], z[t]}]]}]
][[2, 1]];
ListPlot[ps[[All, 2 ;; 3]], PlotStyle -> PointSize[0.001], AxesLabel -> {x, y}]

Mathematica graphics

Plotting the return map of x[t]:

Show[
  ListPlot[Partition[ps[[All, 2]], 2, 1], PlotStyle -> PointSize[0.002]],
  Plot[x, {x, -4, 4}], AxesLabel -> {x[t], x[t + 1]}
]

Mathematica graphics

Now, to find an unstable limit cycle we will use Newton's method, which requires a good initial guess. To get one, we'll scan through the Poincaré section for near misses to an n-peak cycle. First, a 2-peak cycle:

n = 2;
ics = Table[
  If[Abs[ps[[i, 2]] - ps[[i + n, 2]]] < 10^-3,
   {Thread[{x, y, z} -> Mean[{ps[[i + n, 2 ;; 4]], ps[[i + n, 2 ;; 4]]}]], 
    Period -> ps[[i + n, 1]] - ps[[i, 1]]},
   Nothing
  ]
, {i, Length[ps] - n}]
(* {{{x -> 2.66067, y -> -3.507, z -> 25.5}, Period -> 2.78729},
  {{x -> 2.6621, y -> -3.50162, z -> 25.5}, Period -> 2.78703}} *)

Then use that initial guess in my FindEcoCycle:

lc2 = FindEcoCycle[Sequence @@ ics[[1]], Method -> "FindRoot"];
RuleListPlot[lc2]

Mathematica graphics

We can verify that it is an unstable cycle by calculating its Floquet multipliers:

EcoEigenvalues[lc2, Multipliers -> True]
(* {4.9097, 0.999996, 1.80293*10^-7} *)

Greater than 1 means unstable.

We can do the same for 3-peak cycles and 4-peak cycles (there are two kinds: LLRR and LLLR).

lc3 = FindEcoCycle[{x -> -2.783111360797086`, y -> 3.054488804793205`, z -> 25.5},
  Period -> 4.12801717847924`, Method -> "FindRoot"];
lc4 = FindEcoCycle[{x -> -3.256897972998302`, y -> 1.2980664828293624`, z -> 25.5}, 
   Period -> 5.419166840014896`, Method -> "FindRoot"];
lc4b = FindEcoCycle[{x -> 3.0826624273683545`, y -> -1.9196610967506293`, z -> 25.5}, 
   Period -> 5.517358070569571`, Method -> "FindRoot"];
RuleListPlot[{lc3, lc4, lc4b}]

Mathematica graphics

Notice that the periods are close to n multiples of ~1.4, another way to estimate the time spend in each wing.

Finally, put these unstable orbits together with the attractor:

RuleListPlot[{FinalSlice[s, 100], lc2, lc3, lc4, lc4b}, 
  PlotPoints -> 200, PlotStyle -> {{Thin, Gray}, Red, Orange, Green, Blue}]

enter image description here

$\endgroup$
1
  • $\begingroup$ This, of course, is a very advanced answer. I have not studied it completely yet, but it seems to be what we need. After a detailed study I will write questions if they arise.I can’t immediately formulate them yet, until I try this calculation myself. $\endgroup$ – dtn May 31 '20 at 6:25

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.