Slicing through 3D orbitals

F.P. Laussy

March 2021 for the Wolverhampton Lectures on Physics.
http://laussy.org

This is what we demonstrated in class:

α0=1;ψ[n_,l_,m_,r_,θ_,ϕ_]:=Sqrt[(2/(n α0))^3 (n-l-1)!/(2 n ((n+l)!))] E^(-r/(n α0)) ((2 r)/(n α0))^l LaguerreL[n-l-1,2 l+1,(2 r)/(n α0)] SphericalHarmonicY[l,m,θ,ϕ];

n=4;l=2;m=0;

f=TransformedField["Spherical"->"Cartesian",ψ[n,l,m,r,θ,ϕ],{r,θ,ϕ}->{x,y,z}];

Size of the volume to plot:

β=32;

dp=DensityPlot3D[Abs[f]^.5,{x,-β,β},{y,-β,β},{z,-β,β},ColorFunction->(Blend[{White,Blue,Red},#]&),ColorFunctionScaling->True,Boxed->False,Axes->False,RegionFunction->Function[{x,y,z},x<0||y>0],PlotLegends->False,PlotPoints->100,
PlotRegion->Automatic,PreserveImageOptions->Automatic,Prolog->{},RotationAction->"Fit",SphericalRegion->False,Ticks->{Automatic,Automatic,Automatic},TicksStyle->{},TouchscreenAutoZoom->False,ViewAngle->Automatic,ViewCenter->{0.5`,0.5`,0.5`},ViewMatrix->Automatic,ViewPoint->{1.5510701983747839`,-2.974446211839794`,0.44367890707752555`},ViewProjection->Automatic,ViewRange->All,ViewVector->Automatic,ViewVertical->{0.`,0.`,1.`}]

Use FullOptions around the actual output to use the angles you like:

FullOptions[]

1D cut:

Plot[{4π (x^2)(f^2)/.{y->0,z->0},f/.{y->0,z->0}},{x,0,50},PlotRange->All,AxesStyle->"Times",PlotStyle->Thick,Filling->Axis]

Remove[cp]

Step of the animation:

δt=.05;

Easing function:

lC=Table[-Cos[π x],{x,0,2-δt,δt}]

That defines the motion of the slicing plane:

ListPlot[%]

That defines the extent of the slicing plane (in case you don’t want to sweep over it completely):

lz=Chop[19.75 lC]

Length[lz]

Slicing plane:

Do[cp[i]=ContourPlot3D[x==lz[[i]],{x,-β,β},{y,-β,β},{z,-β,β},Boxed->False,Axes->False,Mesh->None,PlotTheme->"ThickSurface",ContourStyle->Opacity[0.5]],{i,Length[lz]}]

Threshold to plot the 2D density plot:

thr=.133

Extent 2D density plot

βdp=50;

ltb=Table[dpz[i]=DensityPlot[((Abs[f])^(.5))/.x->lz[[i]],{y,-βdp,βdp},{z,-βdp,βdp},ColorFunction->(Blend[{White,Blue,Red},#]&[Rescale[#,{0,thr}]]&),PlotPoints->200,PlotRange->{Automatic,Automatic,{0,thr}},
(*PlotLegends->BarLegend[{Automatic,{0,thr}}],*)
ColorFunctionScaling->False,Frame->False],{i,Length[lz]}]

Show one case:

Show[dp,cp[Length[lz]]]

Try with one frame

SetDirectory[NotebookDirectory[]<>"/frames"]

GraphicsGrid[{{Show[dp,cp[1]],dpz[1]}},ImageSize->600]

Export["frame1.png",GraphicsGrid[{{Show[dp,cp[1]],dpz[1]}},ImageSize->600],"PNG",ImageResolution->200]

Do[Export["frame"<>ToString[i]<>".png",GraphicsGrid[{{Show[dp,cp[i]],dpz[i]}},ImageSize->600],"PNG",ImageResolution->180]
,{i,Length[lz]}]

Show[dp,cp]