Ammonia Maser

\(Clear["Global`*"]; \  (*Clear\ all\ previous\ global\ settings\ from\ currently\ open\ sessions*) 
Needs["Graphics`Shapes`"];\)

Molecule figure

Definition of figure

Off[General::spell1]
pts         =  {{0, 0, 0}, {1.2, 0, 0}, {0.5, (Sqrt[5/4]), 
            0}, {0.5, (Sqrt[5/4])/2, 2/(Sqrt[8])}};
siz         =  { .09, 0.09, 
          0.09,  .15};
col         =  {1, 1, 1,  .6};
points  = 
        Table[{Hue[col[[i]]], PointSize[siz[[i]]], 
            Point[pts[[i]]]}, {i, 1, 4}];
lines     =  
        Map[Line, 
          Flatten[Table[
              Table[{pts[[i]], pts[[j]]}, {j, i + 1, 4}], {i, 1, 3}], 
            1]];
dl             =  {Dashing[{0.05, 0.05}], 
          Thickness[ .01], 
          Line[{{pts[[4, 1]], pts[[4, 2]], -pts[[4, 3]]}, 
              pts[[4]]}]};

pp = 
        Graphics3D[{PointSize[0.08], points, lines, dl}, 
          PlotRange -> {{- .1, 1.2}, {0, 1.5}, {- .6,  .8}}, 
          Boxed -> False, Axes -> False, 
          ViewPoint -> {1.786,  -2.497,  1.422}];

Ammonia molecule

Show[pp];

Write to ps-file

\(\(\(SetDirectory["C:\Dateien\wvl\Tex\Vorlesungen\Praktikum"];\)\(
\)\( (*\(Display["ammonia.eps", 
          pp, "EPS"];\)*) \)\)\)

Potential

Definition of figure

$TextStyle = {FontFamily -> "Times", FontSize -> 16, 
          FontWeight -> "Bold"};
g1 = 
        Graphics[{Thickness[ .02], 
            Line[{{-1, 100}, {-1, 0}, {- .25, 0}, {- .25, 
                  1}, { .25, 1}, { .25, 0}, {1, 0}, {1, 100}}]}, 
          PlotRange -> {{-1.5, 1.5}, {- .5, 2}}];
\(\(g2 = \ 
        Graphics[{
			Text[\*""(Subscript[V, 0]) →"", {\(-1.3\), 1}], 
			Text["0 →", {\(-1.3\), 
                0.05}], 
			Text["b", { .25, \(- .2\)}], 
			Text["-b", {\(- .25\), \(- .2\)}], 
			Text["-a", {\(-1\), \(- .2\)}], 
			Text["a", {1, \(- .2\)}], 
			Text["←  Δ  →", {\(- .6\),  .2}], 
			Text["←  Δ  →", { .6,  .2}], 
			Text["↑ ∞", {1.2, 1.9}]
				}, 
          PlotRange -> {{\(-1.5\), 1.5}, {\(- .5\), 2}}];\)\)

Plot Potential

Show[{g1, g2}];

Meaning of Parameters

β  =  (b/Δ)
Δ  =  a - b
k =  (Sqrt[2 m E]) /  ℏ
\(TraditionalForm\`k\_V = \ \@\(2\ m\ V\_0\)/\ ℏ
\)
x     =  k    Δ
xv  =  (Subscript[k, V]) Δ

Eigenvalues

definition of eigenvalue equation

xv  =  6.0;
β    =   .3;
ϵ    =   .00000000001;
nn  =  Floor[((2 xv  +  π)/(2 π))];
fs[x_]  =  
        Tan [x] + 
          (x/(Sqrt[(xv^2) - (x^2)])) Coth[(Sqrt[(xv^2) - (x^2)]) β];
fa[x_]  = 
        Tan [x] + 
          (x/(Sqrt[(xv^2) - (x^2)])) Tanh[(Sqrt[(xv^2) - (x^2)]) β];
Plot[{Tan [
            x], -(x/(Sqrt[(xv^2) - (x^2)])) Coth[(Sqrt[(xv^2) - (x^2)]) β], -(x/(Sqrt[(xv^2) - (x^2)])) Tanh[(Sqrt[(xv^2) - (x^2)]) β]}, {x, 0, xv}, PlotRange -> {{0, xv}, {-5, 5}}, 
        PlotStyle -> {Hue[ .6], Hue[1], 
            Hue[1]}];
\(\(es\  = 
        Flatten[Table[\ \ \ \ x1\  = \ Min[n\ π, xv] - ϵ; \ 
            x0\  = \ n\ π - π/2 + ϵ; \ 
            xm\  = \ \((x0 + x1)\)/2; 
			If[fs[x0]*fs[x1] < 0, 
              x /. FindRoot[
                  fs[x] == 0, {x, xm, x0, 
                    x1}], {}]
\ \ \ \ \ \ \ \ \ \ , {n, 1, 
              nn}]];\)\)
\(\(ea\  = \ 
        Flatten[Table[\ \ \ x1\  = \ Min[n\ π, xv] - ϵ; \ 
            x0\  = \ n\ π - π/2 + ϵ; \ 
            xm\  = \ \((x0 + x1)\)/2; 
			If[fa[x0]*fa[x1] < 0, 
              x /. FindRoot[
                  fa[x] == 0, {x, xm, x0, 
                    x1}], {}]
, {n, 1, nn}]];\)\)

Plot of eigenfunctions

plots

Do[η  =  
          es[[i]]; 
κ  = (Sqrt[(xv^2)-(η^2) ]); 
A  =  Cosh[ κ β];  
        B  =  Sin[η]; 
Ψ[x_] = 
          If[x  <  -β,  A Sin[η (1 + β + x)], 
            If[x  <  β, B Cosh[κ x], 
              A Sin[η (1 + β - 
                        x)]]]; 
Plot[Ψ[
            x], {x, -1 - β, 1 + β}]
, {i, 
          1, Length[es]}];
Do[η  =  
          ea[[i]]; 
κ  = (Sqrt[(xv^2)-(η^2) ]); 
A  =  Sinh[ κ β];  
        B  = -Sin[η]; 
Ψ[x_] = 
          If[x  <  -β,  A Sin[η (1 + β + x)], 
            If[x  <  β, 
              B Sinh[κ x], -A Sin[η (1 + β - 
                        x)]]]; 
Plot[Ψ[
            x], {x, -1 - β, 1 + β}]
, {i, 
          1, Length[ea]}];

Store plots to ps-files

\(\(\( (*\ 
      no\ yet\ finished*) \)\(
\)\(SetDirectory["C:\Dateien\wvl\Tex\Vorlesungen\Praktikum"];\)\(
\)\( (*\(Display["ammonia.eps", 
          pp, "EPS"];\)*) \)\)\)

Dynamics

Definition

s =. ; a =. ;
(Subscript[η, s])  =  es[[1]];
(Subscript[η, a])  =  ea[[1]];
  
(Subscript[κ, s])  = (Sqrt[(xv^2)-((Subscript[η, s])^2) ]);
(Subscript[A, s])  =  Cosh[ (Subscript[κ, s]) β];  
    (Subscript[B, s])  =  Sin[(Subscript[η, s])];
\(\(Ψ\_s[x_] := 
        If[x\  ≤ \ \(-β\), \ 
          A\_s\ Sin[\(η\_s\) \((1 + β + x)\)], 
          If[x\  < \ β, B\_s\ Cosh[κ\_s\ x], 
            A\_s\ Sin[\(η\_s\) \((1 + β - 
                      x)\)]]];\)

 (*\ 
      anti - symmetric\ eigenfunctiom\ *) \)
(Subscript[κ, a])  = (Sqrt[(xv^2)-((Subscript[η, a])^2) ]);
(Subscript[A, a])  =  Sinh[ (Subscript[κ, a]) β];  
    (Subscript[B, a])  =  Sin[(Subscript[η, a])];
\(\(Ψ\_a[x_] := 
        If[x\  < \ \(-β\), \ 
          A\_a\ Sin[\(η\_a\) \((1 + β + x)\)], 
          If[x\  < \ β, \(-B\_a\)\ Sinh[κ\_a\ x], \(-A\_a\)\ Sin[\(η\_a\) \((1 + β - 
                      x)\)]]];\)

 (*time\ evolution\ *) \)
\(\(F[x_, 
          t_]\  := \ E\^\(I\ η\_s\ t\)\ Ψ\_s[
              x]\ \  + \ E\^\(I\ η\_a\ t\)\ Ψ\_a[x];\)
\)
\(\(\(Off[NIntegrate::ncvb]\) \); \ \ \(\(Off[
        NIntegrate::slwcon]\) \); \(\(Z\  = \ 
        NIntegrate[
          Abs[F[x, 0]]\^2, {x, \(-1\) - β, 
            1 + β}]\) \);
\)

Plot

T     =  2  π/((Subscript[η, a]) - (Subscript[η, s])); 
      Nt  =  10;

SetOptions[Plot, 
        DisplayFunction -> Identity];
p = 
        Table[Plot[Abs[F[x, t]]^2/Z, {x, -1 - β, 1 + β}, 
            PlotRange -> {{-1 - β, 1 + β}, {0, 2}}, 
            Ticks -> {{-1, 0, 1}, {}}], {t, 0, 2  T, 
            T/Nt}];
SetOptions[Plot, 
        DisplayFunction -> $DisplayFunction];
Show[#, DisplayFunction -> $DisplayFunction] & /@ p;

(* close all windows *)
	SelectionMove[EvaluationNotebook[], After, 
          EvaluationCell];
	SelectionMove[EvaluationNotebook[], Next, CellGroup];
	FrontEndTokenExecute["OpenCloseGroup"];

Sundries

Period of inter - well oscillations

2  π/(ea[[1]] - es[[1]])

Period of intra - well oscillations

2  π/(es[[2]] - es[[1]])