(* Initialisierungszelle *)
(* Konstanten: a, b, m, α
abh. Konstanten: β[a,b,m,α] *)
beta[a_,b_,m_,α_]:=(Sqrt[((a b)/m)])Sinh[α];betarule=β->beta[a,b,m,α];todaPot[a_,b_,r_]:=(a/b)Exp[-b r]+a r;
solitonr[a_,b_,m_,α_,sign_,n_,t_]=-(1/b)Log[(m/(a b))(β^2)((Sech[α n+sign*β t])^2)+1]/.betarule;solitony[a_,b_,m_,α_,sign_,n_,t_]=(1/b)Log[((1+Exp[2(α(n-1)+sign*β t)])/(1+Exp[2(α n+sign*β t)]))]/.betarule;
solitonyv[a_,b_,m_,α_,sign_,n_,t_]=D[solitony[a,b,m,α,sign,n,t],t];
beta12rules={β1->beta[a,b,m,α1],β2->beta[a,b,m,α2]};
A1toA2[a_,b_,m_,α1_,α2_,A1_]=(1/A1)(((m/(a b))(((β1+β2))^2)-((Sinh[α1+α2])^2))/(((Sinh[α1-α2])^2)-(m/(a b))(((β1-β2))^2)))/.beta12rules;
twosolS[a_,b_,m_,α1_,α2_,A1_,sign1_,sign2_,n_,t_]=(m/b)Log[1+A1 Exp[2(α1 n-sign1 β1 t)]+A2  Exp[2(α2 n-sign2 β2 t)]+Exp[2((α1+α2)n-(sign1 β1+sign2 β2)t)]]/.beta12rules/.A2->A1toA2[a,b,m,α1,α2,A1];
twosoly[a_,b_,m_,α1_,α2_,A1_,sign1_,sign2_,n_,t_]=(1/m)(twosolS[a,b,m,α1,α2,A1,sign1,sign2,n-1,t]-twosolS[a,b,m,α1,α2,A1,sign1,sign2,n,t]);
twosolyv[a_,b_,m_,α1_,α2_,A1_,sign1_,sign2_,n_,t_]=D[twosoly[a,b,m,α1,α2,A1,sign1,sign2,n,t],t];
twosolr[a_,b_,m_,α1_,α2_,A1_,sign1_,sign2_,n_,t_]=-(1/m)(twosolS[a,b,m,α1,α2,A1,sign1,sign2,n+1,t]-2twosolS[a,b,m,α1,α2,A1,sign1,sign2,n,t]+twosolS[a,b,m,α1,α2,A1,sign1,sign2,n-1,t]);
solitonenergy[a_,b_,α_]:=((2a)/b)(Sinh[α]Cosh[α]-α);
cnnu[a_,b_,m_,k_,λ_]:=(1/(2EllipticK[k]))(Sqrt[((a b)/m)])/√((1/((JacobiSN[2EllipticK[k]/λ,k])^2))-1+((EllipticE[k])/(EllipticK[k])));
nurule=ν->cnnu[a,b,m,k,λ];
cnoidalexp[a_,b_,m_,λ_,k_,n_,t_]=((((2EllipticK[k]ν))^2)/(a b/m))(((JacobiDN[2((n/λ)-ν t)EllipticK[k],k])^2)-((EllipticE[k])/(EllipticK[k])))/.nurule;
sumpulse[a_,b_,m_,λ_,k_,n_,l_,t_]=(m/(a b))((β^2)((Sech[α(n-λ l)-β t])^2)(*-2β ν*))/.α->((π EllipticK[k])/(λ EllipticK[(Sqrt[1-(k^2)])]))/.β->((π EllipticK[k]ν)/( EllipticK[(Sqrt[1-(k^2)])]))/.nurule;

Das Toda-Gitter: Solitäre Lösungen

Mathematica-Notebook zum Vortrag. Autor: Deniz Stiegemann

Toda-Potential

Manipulate[Plot[todaPot[a,b,r],{r,-10,10},PlotRange->{0,15},PlotStyle->Thick,AxesLabel->{"r","ϕ"},LabelStyle->{Bold,FontSize->15}],{{a,1},0.01,10},{{b,1},0.01,5}]

Existenz der Solitonlösung

(((∂_(t,t))s[n,t])/((∂_t)s[n,t]+a))==(b/m)(s[n+1,t]-2s[n,t]+s[n-1,t])/.s->Function[{n,t},((β m)/b)Tanh[n α+β t]]/.betarule//Simplify

Zusammenhang zwischen α und β

Plot[beta[1,1,1,α],{α,0,3},PlotStyle->Thick,AxesLabel->{"α","β"},LabelStyle->{Bold,FontSize->15}]

Geschwindigkeit des Solitons in Abhängigkeit von α

Plot[beta[1,1,1,α]/α,{α,0,3},PlotStyle->{Thick,Red},AxesLabel->{"α","c"},LabelStyle->{Bold,FontSize->15}]

Stauchung des Toda-Gitters im Fall der Solitonlösung

Limit[solitony[a,b,m,α,1,-n,0]-solitony[a,b,m,α,1,n,0],n->∞,Assumptions->α>0]

Energie des Solitons

Plot[solitonenergy[1,1,α],{α,0,3},PlotStyle->Thick,AxesLabel->{"α","E"},LabelStyle->{Bold,FontSize->15}]

Animation: 1-Soliton-Lösung des Toda-Gitters

Module[{nmax=22,stepsize=30,displweight=7,radius=7,ycolor=Darker[Green],rcolor=Darker[Orange],
process,a,b,m,α,t,sign},
Manipulate[process[a,b,m,α,t],Column[{Grid[{{
Control[{{a,1,"a"},0.1,3}],
Control[{{b,1,"b"},0.5,3}]},
{Control[{{m,1,"m"},0.5,10}],
Control[{{α,1.3,"α"},0.01,1.7}]}},Alignment->Right,Spacings->2],Column[{Control[{{sign,-1,"Richtung"},{-1->"nach rechts",1->"nach links"}}],
Control[{{t,2,"t"},-15,20,ControlType->Animator,AnimationRate->3,AnimationRunning->False}]},Spacings->2]},Spacings->2],
Initialization:>(

process[a_,b_,m_,α_,t_]:=
Module[{y,r,v,vmax=solitonyv[a,b,m,α,sign,0.5,0]},
y[n_]=solitony[a,b,m,α,sign,n,t];
r[n_]=solitonr[a,b,m,α,sign,n,t];
v[n_]=solitonyv[a,b,m,α,sign,n,t];

Column[{
Graphics[{
Table[{Blend[{Blue,Red},v[n]/vmax],Disk[{y[n]*displweight+n*stepsize,0},radius]},{n,0,nmax}],
Text[Row[{Style["schnell",Red,Bold,15],Style[", ",Bold,15],Style["langsam",Blue,Bold,15]}],{650,-50},{1,0}]},PlotRange->{{-30,700},{-80,20}},ImageSize->Large
],

Plot[{y[n],r[n]},{n,0,nmax},PlotRange->{0,-5},PlotStyle->{{Thick,ycolor},{Thick,rcolor}},AxesLabel->{"n"},LabelStyle->{Bold,FontSize->15},AspectRatio->0.16,ImageSize->570,Epilog->Text[Row[{Style["Auslenkungen",Bold,15],Style[" (Subscript[y, n])",Bold,15,ycolor],Style[",",Bold,15],Style[" (Subscript[r, n])",Bold,15,rcolor]
}],{0.5,-4.6},{-1,0}]
]
},Spacings->1.5,Alignment->Left]

]
)
]
]

Reihendarstellung der periodischen Lösung als Summe solitärer Pulse

Plot[Evaluate[Prepend[Table[sumpulse[1,1,1,0.4,0.9,0,l,t],{l,-3,3}],cnoidalexp[1,1,1,0.4,0.9,0,t]]],{t,-10,10},PlotRange->{-2,3},PlotStyle->{Thick},AxesLabel->{"t","\!\(\*SuperscriptBox[\(e\), \(\(-b\)\\ \*SubscriptBox[\(r\), \(n\)]\)]\)-1"},LabelStyle->{Bold,FontSize->15},ImageSize->500]

Soliton als Grenzfall einer periodischen Welle mit großer Wellenlänge λ->∞ und großem elliptischen Modul k->1

Plot[cnoidalexp[1,1,1,10,.5,0,t],{t,-40,40},PlotRange->{-0.08,0.1}]

Plot[cnoidalexp[1,1,1,100,1-1/10000000,0,t],{t,-40,40},PlotRange->{-0.08,0.1}]

modulusscalingfunction[x_]=c1 Exp[c2 x]+c3/.FindFit[{{10,2},{100,10000000}},c1 Exp[c2 x]+c3,{c1,c2,c3},x];

Manipulate[Plot[cnoidalexp[1,1,1,x,1-1/modulusscalingfunction[x],0,t],{t,-40,40},PlotRange->{-0.08,0.1}],{x,10,100}]

Animation: 2-Solitonen-Lösung

Module[{nmax=50,stepsize=14,displweight=7,radius=3,ycolor=Darker[Green],rcolor=Darker[Orange],
process,a,b,m,α1,α2,A1,t,sign1,sign2},
Manipulate[process[a,b,m,α1,α2,A1,sign1,sign2,t],Column[{Grid[{{
Control[{{a,1,"a"},0.1,3}],
Control[{{b,1,"b"},0.5,3}]},
{Control[{{m,1,"m"},0.5,10}]}},Alignment->Right,Spacings->2],
Grid[{{
Control[{{α1,1,"(Subscript[α, 1])"},-3,3}],
Control[{{α2,1.5,"(Subscript[α, 2])"},-3,3}]},
{Control[{{A1,1,"(Subscript[A, 1])"},0.05,20}]}},Alignment->Right,Spacings->2],
Grid[{{Control[{{sign1,-1,"Richtung 1"},{1->"+",-1->"-"}}],
Control[{{sign2,1,"Richtung 2"},{1->"+",-1->"-"}}]
}}],
Control[{{t,-15,"t"},-15,30,ControlType->Animator,AnimationRate->3,AnimationRunning->False}]},Spacings->2],
Initialization:>(

process[a_,b_,m_,α1_,α2_,A1_,sign1_,sign2_,t_]:=
Module[{y,r,v,vmax=3},
y[n_]=twosoly[a,b,m,α1,α2,A1,sign1,sign2,n,t];
r[n_]=twosolr[a,b,m,α1,α2,A1,sign1,sign2,n,t];
v[n_]=twosolyv[a,b,m,α1,α2,A1,sign1,sign2,n,t];

Column[{
Graphics[{
Table[{Blend[{Blue,Red},Min[Abs[v[n]]/vmax,1]],Disk[{y[n]*displweight+n*stepsize+340,0},radius]},{n,-nmax/2,nmax/2}],
Text[Row[{Style["schnell",Red,Bold,15],Style[", ",Bold,15],Style["langsam",Blue,Bold,15]}],{650,-50},{1,0}]},PlotRange->{{-30,700},{-80,20}},ImageSize->Large
],

Plot[{y[n],r[n]},{n,-nmax/2,nmax/2},PlotRange->{0,-5},PlotStyle->{{Thick,ycolor},{Thick,rcolor}},AxesLabel->{"n"},LabelStyle->{Bold,FontSize->15},AspectRatio->0.16,ImageSize->570,Epilog->Text[Row[{Style["Auslenkungen",Bold,15],Style[" (Subscript[y, n])",Bold,15,ycolor],Style[",",Bold,15],Style[" (Subscript[r, n])",Bold,15,rcolor]
}],{0.5,-4.6},{-1,0}]
]
},Spacings->1.5,Alignment->Left]

]
)
]
]