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];
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.
I would like to know whats wrong with my code. I am trying to solve system of non-linear equations (initially in wolfram but the command was too long) in Mathematica:
Reduce[Pi*(h^2 + 2*R*(R - r))/sqrt (h^2 + (R - r)^2) - 2*x*Pi/3*h*R -
x*Pi/3*h*r == 0 &&
Pi*(h^2 + 2*r*(r - R))/sqrt (h^2 + (R - r)^2) + 2*Pi*r -
x*Pi/3*h*R - 2*x*Pi/3*h*r == 0 &&
Pi*h*(r + R)/sqrt (h^2 + (R - r)^2) - x*Pi/3*R^2 - x*Pi/3*R*r -
x*Pi/3*r^2 == 0 && -Pi/3*h*(R^2 + R*r + r^2) + 1 == 0, {R, r, h,
x}];
Do you know how to retype it and solve these equations? I tried to type it according to documentation, but I evidently made some mistake...
These are the original equations (in LaTeX, I dont know if they will show correctly here:
\begin{equation*}
\frac{\partial}{\partial R} L(R, r, h, \lambda) = \frac{\pi(h^2 + 2R(R-r))}{\sqrt{h^2 + (R - r)^2}} - 2\lambda \frac{\pi}{3}hR - \lambda \frac{\pi}{3}hr= 0
\end{equation*}
\begin{equation*}
\frac{\partial}{\partial r} L(R, r, h, \lambda) = \frac{\pi(h^2 + 2r(r-R))}{\sqrt{h^2 + (R - r)^2}} + 2\pi r - \lambda \frac{\pi}{3}hR - 2\lambda \frac{\pi}{3}hr= 0
\end{equation*}
\begin{equation*}
\frac{\partial}{\partial h} L(R, r, h, \lambda) = \frac{\pi h(r + R)}{\sqrt{h^2 + (R - r)^2}} - \lambda \frac{\pi}{3}R^2 - \lambda \frac{\pi}{3}Rr - \lambda \frac{\pi}{3}r^2= 0
\end{equation*}
\begin{equation*}
\frac{\partial}{\partial \lambda} L(R, r, h, \lambda) = - \frac{\pi}{3} h (R^2 + Rr + r^2) + 1 = 0
\end{equation*}
edit:
I corrected pi to PI, now it started evaluating so maybe it was the mistake...It just takes a very long time...
You have to learn at least the basics. Go to Help->Documentation Center and click on the book in the search bar. There is everything explained from the very start.
As already pointed out in the comments, all functions and built-in symbols start with a capital letter. Therefore your call should be
Reduce[Pi*(h^2 + 2*R*(R - r))/Sqrt[h^2 + (R - r)^2] - 2*x*Pi/3*h*R -
x*Pi/3*h*r == 0 &&
Pi*(h^2 + 2*r*(r - R))/Sqrt[h^2 + (R - r)^2] + 2*Pi*r -
x*Pi/3*h*R - 2*x*Pi/3*h*r == 0 &&
Pi*h*(r + R)/Sqrt[h^2 + (R - r)^2] - x*Pi/3*R^2 - x*Pi/3*R*r -
x*Pi/3*r^2 == 0 && -Pi/3*h*(R^2 + R*r + r^2) + 1 == 0, {R, r, h,
x}]
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]