I'm working with chaotic attractors, and testing some continuous-> discrete equivalences. I've made a continuous simulation of the Rossler system this way
a = 0.432; b = 2; c = 4;
Rossler = {
x'[t] == -y[t] - z[t],
y'[t] == x[t] + a*y[t],
z'[t] == b + x[t]*z[t]-c*z[t]};
sol = NDSolve[
{Rossler, x[0] == y[0] == z[0] == 0.5},
{x, y, z}, {t,500}, MaxStepSize -> 0.001, MaxSteps -> Infinity]
Now, when trying to evaluate a discrete equivalent system with RSolve, Mma doesn't do anything, not even an error, it just can't solve it.
RosslerDiscreto = {
x[n + 1] == x[n] - const1*(y[n] + z[n]),
y[n + 1] == 1 - a*const2)*y[n] + const2*x[n],
z[n + 1] == (z[n]*(1 - const3) + b*const3)/(1 - const3*x[n])}
I want to know if there is a numerical function for RSolve, analogous as the NDSolve is for DSolve.
I know i can make the computation with some For[] cycles, just want to know if it exists such function.
RecurrenceTable is the numeric analogue to RSolve:
rosslerDiscreto = {
x[n+1] == x[n] - C[1]*(y[n] + z[n]),
y[n+1] == (1 - a*C[2])*y[n] + C[2]*x[n],
z[n+1] == (z[n]*(1 - C[3]) + b*C[3]) / (1 - C[3]*x[n]),
x[0] == y[0] == z[0] == 0.5
} /. {a->0.432, b->2, c->4, C[1]->0.1, C[2]->0.1, C[3]->0.1};
coords = RecurrenceTable[rosslerDiscreto, {x,y,z}, {n,0,1000}];
Graphics3D#Point[coords]
Related
for work I have to solve the Optical Bloch Equations for a 2-Level System and I appear to be really stuck on my code in Mathematica:
O=1;
g=1;
d=0;
sol3=NDSolve
[
{
x'[t]==g y[t] + I/2 (O* b[t] - O a[t]),
y'[t]==-g y[t]+ I/2 (O a[t]-O* b[t]),
a'[t]==-(g/2+I d) a[t] + I/2 =O* (y[t]-x[t]),
b'[t]==-(g/2-I d) b[t] + I/2 O* (x[t]-y[t]),
x[0]==1,
y[0]==0,
b[0]==0,
a[0]==0
},
{x,y},{t,0,100}
]
The Error I get is: Syntax::tsntxi: "whole DE-System" is incomplete; more input is needed.
I would be very grateful if you could point out my error(s)
Thank you all :)
w = 1;
g = 1;
d = 0;
swl3 = NDSolve[{
x'[t] == g y[t] + I/2 (w*b[t] - w a[t]),
y'[t] == -g y[t] + I/2 (w a[t] - w*b[t]),
a'[t] == -(g/2 + I d) a[t] + I/2 w*(y[t] - x[t]),
b'[t] == -(g/2 - I d) b[t] + I/2 w*(x[t] - y[t]),
x[0] == 1, y[0] == 0, b[0] == 0, a[0] == 0},
{x, y, a, b},
{t, 0, 100}]
Plot[Evaluate[{x[t], y[t], a[t], b[t]} /. swl3], {t, 0, 100}]
a[t] and b[t] are complex so they don't appear in the plot. You can plot the real and imaginary part separately.
I have set of time dependent equations. 4 equations with 4 time dependent variables {r[t], c[t], Uo[t], U1[t]}.
Those 4 variables need to be used for a parametric transformation function
zJouko[o_] := r[t]*Exp[o*I] + (Uo[t]/(Exp[o*I] - c[t])) + U1[t]. o has nothing to do with the time parameter.
I need to plot this parametric function zJouko[o] for few time intervals on the same figure.
I have initial conditions for the 4 variables.
I have tried to use NSolve and then use its results to the plot but unsuccessfully.
Another problem is that when I launch Mathematica NSolve is working for several times and after that return empty solution.
I have tried this code unsuccessfully. I also don't know where to put the time intervals in the code.
some constants:
q2 = 0.5; mu1 = 1; mu2 = 1; tau = 1.0;
NSolve with the 4 equations and initial conditions
setEquation = NSolve[
{Uo[t]/c[t] == U1[t],
q2 == (r[t]/c[t]) + (Uo[t]*c[t]/(1 - ((c[t])^2))) + U1[t],
mu1*Exp[-t/tau] == r[t]*(r[t] - (Uo[t]/((c[t])^2))),
mu2*Exp[-t/tau] ==
Uo[t]*(((Uo[t])/((((c[t])^2) - 1)^2)) - r[t]/((c[t])^2)),
r[0] == 1/100, Uo[0] == -1/2, U1[0] == -5/12, c[0] == 6/5}, {r[t],
c[t], Uo[t], U1[t]}]
the function and the ParametricPlot:
zJouko[o_] := r[t]*Exp[o*I] + (Uo[t]/(Exp[o*I] - c[t])) + U1[t];
ParametricPlot[{Re[zJouko[o]], Im[zJouko[o]]}, {o, 0, 2 Pi}]
In a fresh start of Mathematica I give it
q2 = 1/2; mu1 = 1; mu2 = 1; tau = 1;
setEquation = Reduce[{Uo[t]/c[t] == U1[t],
q2 == (r[t]/c[t]) + (Uo[t]*c[t]/(1 - ((c[t])^2))) + U1[t],
mu1*Exp[-t/tau] == r[t]*(r[t] - (Uo[t]/((c[t])^2))),
mu2*Exp[-t/tau] == Uo[t]*(((Uo[t])/((((c[t])^2) - 1)^2)) - r[t]/((c[t])^2)),
r[0] == 1/100, Uo[0] == -1/2, U1[0] == -5/12, c[0] == 6/5},
{r[t], c[t], Uo[t], U1[t]}]
and it tells me r[t] is either plus or minus Sqrt[16 + E^t]/(4*Sqrt[2]*Sqrt[E^t]) and then given that choice of r[t]
c[t] == 4*r[t]
Uo[t] == r[t] - 16*r[t]^3
U1[t] == (1 - 16*r[t]^2)/4
Test the solution to see if it is correct.
q2 = 1/2; mu1 = 1; mu2 = 1; tau = 1;
r[t_]:=Sqrt[16 + E^t]/(4*Sqrt[2]*Sqrt[E^t]);
c[t_]:= 4*r[t];
Uo[t_]:=r[t] - 16*r[t]^3;
U1[t_]:= (1 - 16*r[t]^2)/4;
Simplify[ {Uo[t]/c[t] == U1[t],
q2 == (r[t]/c[t]) + (Uo[t]*c[t]/(1 - ((c[t])^2))) + U1[t],
mu1*Exp[-t/tau] == r[t]*(r[t] - (Uo[t]/((c[t])^2))),
mu2*Exp[-t/tau] == Uo[t]*(((Uo[t])/((((c[t])^2) - 1)^2)) - r[t]/((c[t])^2))}]
and this returns
{True, True, True, True}
Check your conditions at t==0
{r[0],c[0],Uo[0],U1[0]}//N
and it returns
{0.728869, 2.91548, -5.46651, -1.875}
Plot your function
zJouko[o_]:= r[t]*Exp[o*I] + (Uo[t]/(Exp[o*I] - c[t])) + U1[t];
Plot[Table[{Re[zJouko[o]], Im[zJouko[o]]},{t,0,2}], {o, 0, 2 Pi}]
Please try to check all this carefully and see if you can find that I have made a mistake anywhere.
I am solving a project in Mathematica 10 and I think that the best way to do it is using a loop like For or Do. After build it I obtain the results I looking for but with a to much big multiplicity. Here is the isolated part of the code:
(*Initializing variables*)
epot[0] = 1; p[0] = 1; \[Psi][0] = HermiteH[0, x] E^(-(x^2/2));
e[n_] := e[n] = epot[n];
(*Defining function*)
\[Psi][n_] := \[Psi][n] = (Sum[p[k]*x^k,{k,0,4*n}]) [Psi][0];
(*Differential equation*)
S = - D[D[\[Psi][n], x], x] + x^2 \[Psi][n] + x^4 \[Psi][n - 1] - Sum[e[n-k]*\[Psi][k],{k,0,n}];
(*Construction of the loop*)
S1 = Collect[E^(x^2/2) S, x, Simplify];
c = Coefficient[S1, x, 0];
sol = Solve[c == 0, epot[n]]; e[n] = epot[n] /. sol;
For[j = 1, j <= 4 n, j++,
c = Coefficient[S1, x, j];
sol = Solve[c == 0, p[j]];
p[j] = p[j] /. sol;];
(*Results*)
Print[Subscript[e, n], "= ", e[n] // InputForm];
Subscript[e, 1]= {{{3/4}}}
Print[ArrayDepth[e[n]]];
3 (*Multiplicity, it should be 1*)
Print[Subscript[\[Psi], n], "= ", \[Psi][n]];
Subscript[\[Psi], 1]= {{E^(-(x^2/2)) (1-(3 x^2)/8-x^4/8)}}
Print[ArrayDepth[\[Psi][n]]];
2 (*Multiplicity, it should be 1*)
After this calculation, the question remaining is how do i substitute this results in the original functions. Thank you very much.
Iam trying to solve the Optical Bloch equations for two level using mathematica.
here is the code i wrote. i want to solve for Rho12 and see the variation of Imaginary part of Rho12 with respect to detuning [Capital Delta].
It is showing error that "they are transcendental equations"
Can some one help me....
\[CapitalOmega]21 = Conjugate[\[CapitalOmega]12];
n := \[Rho]11 + \[Rho]22 + \[Rho]12 + \[Rho]21 = 1;
Solution == DSolve[{
\[Rho]11'[t] == (\[CapitalGamma]2*\[Rho]22[t]) +
i/2 (\[CapitalOmega]21*\[Rho]12[t] - \[CapitalOmega]12*\[Rho]21[
t]),
\[Rho]22'[t] == -\[CapitalGamma]2*\[Rho]22[t] +
i/2 (\[CapitalOmega]12*\[Rho]21[t] - \[CapitalOmega]21*\[Rho]12[
t]),
\[Rho]12'[
t] == (-(\[CapitalGamma]2/2) - i*\[CapitalDelta])*\[Rho]12[t] +
i/2*\[CapitalOmega]12*(\[Rho]11[t] - \[Rho]22[t]),
\[Rho]21'[t] == Conjugate[\[Rho]12'[t]] ,
\[Rho]22[0] == 0, \[Rho]11[0] == 1, \[Rho]12[0] ==
0, \[Rho]21[0] == 0}, {\[Rho]11[t], \[Rho]22[t], \[Rho]12[
t], \[Rho]21[t]}, t];
I have intialconditions:
sf = 200;
sm = 100;
p = 40;
betaf = 0.15;
betam = 0.15;
mums = 0.02;
mufs = 0.02;
sigma = 0.20;
mum = 0.02;
muf = 0.02;
and the ODE:
sf' := -muf*sf + (betaf + mums + sigma)*p - HarmonicMean[sf, sm];
sm' := -mum*sm + (betam + mufs + sigma)*p - HarmonicMean[sf, sm}];
p' := p - (mufs + mums + sigma)*p + HarmonicMean[{sf, sm}];
That i want is an abstract solution (sf(t),sm(t),p(t)) with NDSolve to plot it later.
My problem is that all variables are dependet in all 3 equations, so i don't know how to write the NDSolve call.
I could not manage to get an analytic solution, but the numerical one goes like this. Note that not all symbols you listed are variables of the system: those not being dependent of the independent variable t are parameters. (Also note that there are some typos in the OP's code).
variables = {sf[t], sm[t], p[t]};
parameters = {betaf -> 0.15, betam -> 0.15, mums -> 0.02,
mufs -> 0.02, sigma -> 0.20, mum -> 0.02, muf -> 0.02};
equations = {
sf'[t] == -muf*sf[t] + (betaf + mums + sigma)*p[t] -
HarmonicMean[{sf[t], sm[t]}],
sm'[t] == -mum*sm[t] + (betam + mufs + sigma)*p[t] -
HarmonicMean[{sf[t], sm[t]}],
p'[t] ==
p[t] - (mufs + mums + sigma)*p[t] + HarmonicMean[{sf[t], sm[t]}],
sf[0] == 200,
sm[0] == 100,
p[0] == 40
};
sol = NDSolve[equations /. parameters, variables, {t, 0, 100}];
Plot[Evaluate[variables /. sol], {t, 0, 100}]