Initialisierung

SelectionMove[EvaluationNotebook[],All,Notebook]
SetOptions[NotebookSelection[EvaluationNotebook[]],CellContext->Notebook]

SetOptions[PolarPlot,LabelStyle->{FontFamily->"Helvetica",FontSize->16}];
SetOptions[DensityPlot,LabelStyle->{FontFamily->"Helvetica",FontSize->16}];
SetOptions[Plot,LabelStyle->{FontFamily->"Helvetica",FontSize->16}];

sol2=(E^(-k r)) (r^l)LaguerreL[-1+(( 1)/(a k))-l,1+2 l,2 k r];

wavenumber=Solve[-1+(( 1)/(a k))-l==nr,k][[1]];

R[r_,n_,l_]=Cr sol2/.wavenumber/.{nr->n-l-1}

CNorm[i_,j_,a1_]:=Block[{a=a1,r},Cr/.Solve[Integrate[Evaluate[((R[r,i,j])^2)](r^2),{r,0,∞},Assumptions->{a>0}]==1,Cr][[2]]]

Rnl[r_,n_,l_,a_:1]:=CNorm[n,l,a] (E^(-(r/(a n)))) (r^l) LaguerreL[-1+n-l,1+2 l,((2 r )/(a n))]
Y[l_Integer,m_Integer,θ_,ϕ_]:=SphericalHarmonicY[l,m,θ,ϕ]
Ψ[r_,θ_,ϕ_,n_,l_,m_,a_:1]:=Rnl[r,n,l,a]Y[l,m,θ,ϕ]
ElectronDensity[r_,θ_,ϕ_,n_,l_,m_,a_:1]:=Conjugate[Ψ[r,θ,ϕ,n,l,m,a]]Ψ[r,θ,ϕ,n,l,m,a]
ElectronDensity[Ψ_]:=Conjugate[Ψ] Ψ

blueredcolorPMfunc01[zval_,max_:1] := Module[
{},
Which[0.5<(zval/max)<1,
Hue[1.0,Abs[(zval/max)],0.9],
(zval/max)>=1,
Hue[1.0,1,0.9],
0<(zval/max)<0.5,
Hue[0.63,Abs[(zval/max)],0.9],
(zval/max)≤0,
Hue[0.63,1,0.9]
]
]

legendscale = Table[{ColorData["ThermometerColors"][i],Rectangle[{.1,i},{.2,i+.1}]},{i,0,1.0,.01}];

legendtext[max_]:= Table[Text[Style[NumberForm[max N[-2 i +1],2],FontSize-> 10],{.33,(.95 - i)1.0+.1}],{i,0,1.,1/10}];

NiceLegend[max_] := Show[Graphics[{{GrayLevel[1],Rectangle[{0,-.1},{.4,1.1}]},Line[{{0,-.1},{.4,-.1},{.4,1.2},{0,1.2},{0,-.1}}],legendscale,legendtext[max],Line[{{.1,0},{.2,0},{.2,1.1},{.1,1.1},{.1,0}}]}],AspectRatio -> Automatic,PlotRange -> All]

NiceLegend[max_] := Show[Graphics[{legendscale,legendtext[max]}],AspectRatio -> Automatic,PlotRange -> All]

ShowCodeButton:=DynamicModule[{mode=1(*show*)},SelectionMove[EvaluationNotebook[],All,EvaluationCell];
SetOptions[NotebookSelection[EvaluationNotebook[]],CellOpen->False];
Button[Dynamic[If[mode==1,"Show code","Hide code"]],If[mode==1,SelectionMove[EvaluationNotebook[],All,EvaluationCell];
SelectionMove[EvaluationNotebook[],Previous,Cell];SetOptions[NotebookSelection[EvaluationNotebook[]],CellOpen->True];
mode=2,
(*else*)
SelectionMove[EvaluationNotebook[],All,EvaluationCell];
SelectionMove[EvaluationNotebook[],Previous,Cell];SetOptions[NotebookSelection[EvaluationNotebook[]],CellOpen->False];
mode=1
]
]
]

Betrag der Wellenfunktion |ψ| in der XZ Ebene und Elektronendichte |ψ((|)^2)

ShowCodeButton
Manipulate[m=Round[m];If[l>=n,l=n-1];
If[Abs[m]>l,m=0];
Grid[{{
PolarPlot[Evaluate[Abs[Rnl[1,n,l,1]Y[l,m,θ+π/2,0]]],{θ,0,2π},PlotRange->All,ImageSize->400,FrameLabel->{"x","z"},Frame->True,LabelStyle->{FontFamily->"Helvetica",FontSize->16}],
Show[SphericalPlot3D[Evaluate[ElectronDensity[r,θ,ϕ,n,l,m]],{θ,0,π},{ϕ,0,2π},PlotRange->All,PlotStyle->Directive[Orange,Specularity[White,10]],Boxed->False,Axes->False]]}}],{{n,1},1,3,1,ControlType->Slider,Appearance->"Labeled"},{{l,0},0,n-1,1,ControlType->Slider,Appearance->"Labeled"},{{m,0},-l,l,1,ControlType->Slider,Appearance->"Labeled"},{{r,3},1,10,ControlType->Slider,Appearance->"Labeled"},LabelStyle->Large,SaveDefinitions->True]

Kugelflächenfunktion |(Subscript[Y, nlm])((|)^2)

ShowCodeButton
Manipulate[m=Round[m];If[l>=n,l=n-1];
If[Abs[m]>l,m=0];
Grid[{{PolarPlot[Evaluate[((Abs[Y[l,m,θ+π/2,0]])^2)],{θ,0,2π},PlotRange->All,ImageSize->400,FrameLabel->{"x","z"},Frame->True,LabelStyle->{FontFamily->"Helvetica",FontSize->16}],
Show[SphericalPlot3D[Evaluate[((Abs[Y[l,m,θ,0]])^2)],{θ,0,π},{ϕ,0,2π},PlotRange->All,PlotStyle->Directive[Orange,Specularity[White,10]],Boxed->False,Axes->False]]}}],{{n,1},1,5,1,ControlType->Slider,Appearance->"Labeled"},{{l,0},0,n-1,1,ControlType->Slider,Appearance->"Labeled"},{{m,0},-l,l,1,ControlType->Slider,Appearance->"Labeled"},LabelStyle->Large,SaveDefinitions->True]

Radialteil der Wellenfunktion

ShowCodeButton
wfPlots=Table[Plot[Evaluate[Table[Rnl[r,n,l],{l,0,n-1}]],{r,0,20},PlotRange->All,FrameLabel->{"r[(Subscript[a, 0])]","(Subscript[R, nl])(r)"},Frame->True,ImageSize->600,PlotStyle->Table[If[i==l+1,{Opacity[1],Thickness[0.0075]},{GrayLevel[0.6],Thin}],{i,n}],LabelStyle->{FontFamily->"Helvetica",FontSize->16}],{n,1,4},{l,0,n-1}];
Manipulate[Check[wfPlots[[n,l+1]],l=n-1],{{n,1},1,Length[wfPlots],1,ControlType->Slider,Appearance->"Labeled"},{{l,0},0,n-1,1,ControlType->Slider,Appearance->"Labeled"},LabelStyle->Large,SaveDefinitions->True]

Radialteil der Wahrscheinlichkeitsdichte p(r)

ShowCodeButton
pdPlots=Table[Plot[Evaluate[Table[((Rnl[r,n,l] )^2)(r^2),{l,0,n-1}]],{r,0,40},PlotRange->All,FrameLabel->{"r[(Subscript[a, 0])]","p(r)"},Frame->True,ImageSize->600,PlotStyle->Table[If[i==l+1,{Opacity[1],Thickness[0.0075]},{GrayLevel[0.6],Thin}],{i,n}],LabelStyle->{FontFamily->"Helvetica",FontSize->16}],{n,1,4},{l,0,n-1}];
Manipulate[Check[pdPlots[[n,l+1]],l=n-1],{{n,1},1,Length[pdPlots],1,ControlType->Slider,Appearance->"Labeled"},{{l,0},0,n-1,1,ControlType->Slider,Appearance->"Labeled"},LabelStyle->Large,SaveDefinitions->True]

Dichteplots: Wellenfunktion, Wahrscheinlichkeitsamplitude

ShowCodeButton
Manipulate[m=Round[m];If[l>=n,l=n-1];
If[Abs[m]>l,m=0];
Grid[{{DensityPlot[Evaluate[Ψ[(Sqrt[(x^2)+(y^2)]),ArcTan[y,x],0,n,l,m,1]],{x,-z,z},{y,-z,z},ImageSize->400,FrameLabel->{"x [(Subscript[a, 0])]","z [(Subscript[a, 0])]"},Frame->True,PlotPoints->70,ColorFunction->Function[{x},ColorData["ThermometerColors"][x/cl/2+0.5]],PlotRange->{-cl,cl},ClippingStyle->Automatic,ColorFunctionScaling->False,LabelStyle->{FontFamily->"Helvetica",FontSize->16}],
NiceLegend[cl],
DensityPlot[Evaluate[((Abs[Ψ[(Sqrt[(x^2)+(y^2)]),ArcTan[y,x],0,n,l,m,1]])^2)],{x,-z,z},{y,-z,z},ImageSize->400,FrameLabel->{"x [(Subscript[a, 0])]","z [(Subscript[a, 0])]"},Frame->True,PlotPoints->70,ColorFunction->Function[{x},ColorData["ThermometerColors"][x/(cl^2)/2+0.5]],PlotRange->{-(cl^2),(cl^2)},ClippingStyle->Automatic,ColorFunctionScaling->False,LabelStyle->{FontFamily->"Helvetica",FontSize->16}],
NiceLegend[(cl^2)]
}}],{{n,4},1,5,1,ControlType->Slider,Appearance->"Labeled"},{{l,3},0,n-1,1,ControlType->Slider,Appearance->"Labeled"},{{m,1},-l,l,1,ControlType->Slider,Appearance->"Labeled"},{{z,40,"Zoom"},0,100,ControlType->Slider,Appearance->"Labeled"},{{cl,0.005,"Clip"},0,0.01,ControlType->Slider,Appearance->"Labeled"},LabelStyle->Large,SaveDefinitions->True]

Quantisierung des Drehimpulses

Funktionen

Clear[sphere,Arrowlm]

xy=ParametricPlot3D[{r Cos[θ],r Sin[θ],0},{θ,0,2 π},PlotStyle->{Opacity[0.3]},Boxed->False,Axes->False];
yz=ParametricPlot3D[{0,r Cos[θ],r Sin[θ]},{θ,0,2 π},PlotStyle->{Opacity[0.3]},Boxed->False,Axes->False];
xz=ParametricPlot3D[{r Cos[θ],0,r Sin[θ]},{θ,0,2 π},PlotStyle->{Opacity[0.3]},Boxed->False,Axes->False];
lcirc[l_]:=ParametricPlot3D[{Table[{(Sqrt[l(l+1)-(m^2)])Sin[u],(Sqrt[l(l+1)-(m^2)])Cos[u],m},{m,-l,l}]},{u,0,2π},PlotStyle->{Opacity[0.5],Black}]
mdisk[l_,m_]:=ParametricPlot3D[{r Sin[u],r Cos[u],m},{u,0,2π},{r,0,(Sqrt[l(l+1)-(m^2)])},PlotStyle->{Opacity[0.2],Red},Mesh->None,PerformanceGoal->"Quality"]
sphere[l_,m_]:=With[{r=(Sqrt[l (1+l)])},Show[Graphics3D[{Blue,Lighting->"Neutral",Opacity[.1],Sphere[{0,0,0},r],Black,Opacity[1],Thick,Opacity[0.7],Line[{{0,r,0},{0,-r,0}}],Line[{{0,0,r},{0,0,-r}}],Line[{{r,0,0},{-r,0,0}}]}],lcirc[l],mdisk[l,m],Boxed->False]]
Arrowlm[l_,m_]:=Graphics3D[{Red,Arrow[Tube[{{0,0,0},{(Sqrt[l(l+1)-(m^2)]),0,m}}]]}]
Arrowlm[l_,m_,ϕ_]:=Graphics3D[{Red,Rotate[Arrow[Tube[{{0,0,0},{(Sqrt[l(l+1)-(m^2)]),0,m}}]],ϕ,{0,0,1}]}]

Plot

ShowCodeButton
Manipulate[If[Abs[m]>l,m=0];Animate[Show[{sphere[l,m],Arrowlm[l,m,ϕ],Graphics3D[{Black,Table[Polygon[{{-0.1,0.1,n},{0.1,0.1,n},{0.1,-0.1,n}}],{n,-l,l}]}]},ViewPoint->10*{1,0.4,0.3},PlotRange->(Sqrt[12]),Epilog->Inset[Style["⟨(OverHat[l])⟩= "<>ToString[(Sqrt[ToString[l(l+1)]]),TraditionalForm]<>"ℏ",16,FontFamily->"Helvetica"],Scaled[{0.8,0.1}]]],{ϕ,0,2π,2π/50},DisplayAllSteps->True,AnimationRunning->False],{l,1,3,1,ControlType->Slider,Appearance->"Labeled"},{{m,0},-l,l,1,ControlType->Slider,Appearance->"Labeled"},LabelStyle->Large,SaveDefinitions->True]