Angular Momentum Addition

Init

Load Packages :

<<PhysicalConstants`
<<Graphics`Shapes`

ℏ=1;

Rotation Matrix for drawing correct angles of the vectors:

U[ϕ_]:=(({{Cos[ϕ], Sin[ϕ]}, {-Sin[ϕ], Cos[ϕ]}}));

Single Electron (Spin - Orbit Coupling)

Orbital angular momentum :

(* set quantum number l*)
l=1;
(* absolute value of the orbital angular momentum *)
absl=ℏ(Sqrt[l(l+1)]);
(* calculate angle to quantization axis (Subscript[ϕ, l])*)
ϕl[lp_,mlp_]:=ArcCos[((ℏ mlp)/(ℏ(Sqrt[l(l+1)])))];
(* make grid lines and labels for magnetic quantum number *)
magneticl=Table[Line[{{0,ml},{absl Sin[ϕl[l,ml]],ml}}],{ml,-l,l,1}];
magneticllabel=Table[Text[Style[ml "ℏ",FontSize->16],{-0.2,ml}],{ml,-l,l,1}];
(* create vectors for the different orbital angular momentum eigenstates *)
vectororbit=Table[{{0,0},{absl Sin[ArcCos[ℏ ml(1/absl)]],absl Cos[ArcCos[ℏ ml(1/absl)]]}},{ml,-l,l,1}];

(* Graph it *)
Graphics[
{Text[Style["(Subscript[L, z])",Bold,Large],{-.2,absl}],
Sequence@@magneticllabel,
Dashed,Red,Thick,Sequence@@magneticl,
Black,Thick,Dashing[{}],Arrow[{{0,-absl},{0,absl }}],
Circle[{0,0},absl,{-π/2,π/2}],
Arrow/@vectororbit
},
AspectRatio->Automatic]

Spin angular momentum :

s=1/2;
abss=ℏ(Sqrt[s(s+1)]);
ϕs[sp_,msp_]:=ArcCos[((ℏ msp)/(ℏ(Sqrt[s(s+1)])))];
magnetics=Table[Line[{{0,ms},{abss Sin[ϕs[s,ms]],ms}}],{ms,-s,s,1}];
magneticslabel=Table[Text[Style[ms "ℏ",FontSize->16],{-0.2,ms}],{ms,-s,s,1}];
vectorspin=Table[{{0,0},{abss Sin[ArcCos[ℏ ms(1/abss)]],abss Cos[ArcCos[ℏ ms(1/abss)]]}},{ms,-s,s,1}];
Graphics[
{Text[Style["(Subscript[S, z])",Bold,Large],{-.2,abss}],
Sequence@@magneticslabel,
Dashed,Red,Thick,Sequence@@magnetics,
Black,Thick,Dashing[{}],Arrow[{{0,-abss},{0,abss }}],
Circle[{0,0},abss,{-π/2,π/2}],
Arrow/@vectorspin
},
AspectRatio->Automatic]

Total angular momentum j = l ± s :

The total angular momentum J is given by the sum of the orbital angular momentum and the spin angular momentum :

j = l + s

Depending on the orientation of the spin  parallel or anti - parallel to the magnetic field j can be l + 1/2 or l - 1/2

In vector notation,  the vector sum of the spin ((OverVector[s]))and the orbital angular momentum ((OverVector[l]))gives the total angular momentum  (OverVector[j])=(OverVector[l])+(OverVector[s]).

The lengths of the spin and orbital angular momentum vectors can be measured (along with (j^2) and (Subscript[j, z])) with arbitrary precision and are given by 
|(OverVector[s])(|^2) =ℏ(Sqrt[s (s+1)])and |(OverVector[l])(|^2) =ℏ(Sqrt[l (l+1)]).

The angle (Subscript[ϕ, ls])between the vector (OverVector[s]) and (OverVector[l])  is then determined by

|(OverVector[j])((|)^2)=|(OverVector[l])+(OverVector[s])(|^2)=|(OverVector[l])(|^2)+|(OverVector[s])(|^2)+2 (OverVector[l])(OverVector[s])=|(OverVector[l])(|^2)+|(OverVector[s])(|^2)+2 |(OverVector[l])| |(OverVector[s])|cos((Subscript[ϕ, ls]))

with |(OverVector[k])|=ℏ(Sqrt[k(k+1)]):

cos((Subscript[ϕ, ls])) =((|(OverVector[j])((|)^2)-|(OverVector[l])(|^2)-|(OverVector[s])(|^2))/(2 |(OverVector[l])| |(OverVector[s])|))=((j(j+1)-l(l+1)-s(s+1))/(2(Sqrt[ l(l+1) s(s+1)])))

ϕls[jp_,lp_,sp_]:=ArcCos[(((jp(jp+1)-sp(sp+1)-lp(lp+1)))/(2(Sqrt[sp(sp+1)])(Sqrt[lp(lp+1)])))]/;jp>0&&sp>0&&lp>0
ϕls[jp_,lp_,sp_]:=π/;jp==0
ϕls[jp_,lp_,sp_]:=0;
U[jp_,lp_,sp_]:=U[ϕls[jp,lp,sp]]

Note on the construction of the vectors :

The construction of the vectors for the diagram takes the vector |(OverVector[l])| pointing in x-direction with length ℏ(Sqrt[l(l+1)])and adds the vector 
|(OverVector[s])| rotated by (Subscript[ϕ, ls]) with the unitary matrix U[(Subscript[ϕ, ls])]. The resulting vector |(OverVector[j])| encloses an 
angle (Subscript[ϕ, j])=arccos((mj/(Sqrt[j(j+1)])))with the quantization direction in z-direction and therefore the constructed vector has to be rotated once more.

(* angle between (OverVector[j]) and quantization axis along the z-direction *)
ϕj[jp_,mjp_]:=ArcCos[((ℏ mjp)/(ℏ(Sqrt[jp(jp+1)])))];
(* rotation angle for correct construction *)
ϕjconstr[jp_,mjp_,lp_,sp_]:=ϕj[jp,mjp]-ArcSin[((Sqrt[sp(sp+1)])/(Sqrt[jp(jp+1)]))Sin[ϕls[jp,lp,sp]]]-π/2/;jp>0&&lp>0
ϕjconstr[jp_,mjp_,lp_,sp_]:=0

Vectors for graph:

(* (OverVector[j]) - construction*)
(*direct construction of j: vectortot=Table[{{0,0},{absj Cos[ArcSin[ℏ mj(1/absj)]],absj Sin[ArcSin[ℏ mj(1/absj)]]}},{mj,-(l+s),(l+s),1}];*)
vectorj[jp_,mjp_,lp_,sp_]:={{0,0},U[ϕjconstr[jp,mjp,lp,sp]].({(Sqrt[lp(lp+1)]),0}+U[ϕls[jp,lp,sp]].{(Sqrt[sp(sp+1)]),0})};
(* (OverVector[l]) - construction*)
vectorl[jp_,mjp_,lp_,sp_]:={{0,0},U[ϕjconstr[jp,mjp,lp,sp]].{(Sqrt[lp(lp+1)]),0}}
(* (OverVector[s]) - starting from origin *)
vectorsorig[jp_,mjp_,lp_,sp_]:={{0,0},U[ϕjconstr[jp,mjp,lp,sp]].((Sqrt[sp(sp+1)]){Cos[ϕls[jp,lp,sp]],-Sin[ϕls[jp,lp,sp]]})}
(* (OverVector[s]) - points from the tip of (OverVector[l]) to the tip of (OverVector[j])*)
vectors[jp_,mjp_,lp_,sp_]:={U[ϕjconstr[jp,mjp,lp,sp]].{(Sqrt[lp(lp+1)]),0},U[ϕjconstr[jp,mjp,lp,sp]].({(Sqrt[lp(lp+1)]),0}+((Sqrt[sp(sp+1)]){Cos[ϕls[jp,lp,sp]],-Sin[ϕls[jp,lp,sp]]}))}

l=1, s=1/2, j=3/2

l=1;
s=1/2;
j=l+s;
absj=(Sqrt[j(j+1)])ℏ;

j = l + s

Possible values of mj = -3/2, -1/2, 1/2, 3/2:

magneticj=Table[Line[{{0,mj},{absj Cos[ArcSin[(mj/absj)]],mj}}],{mj,-(l+s),(l+s),1}];
magneticjlabel=Table[Text[Style[mj "ℏ",FontSize->16],{-0.2,mj}],{mj,-(l+s),(l+s),1}];

vectorjarrows=Table[Arrow[vectorj[j,mj,l,s]],{mj,-(l+s),(l+s),1}];
vectorlarrows=Table[Arrow[vectorl[j,mj,l,s]],{mj,-(l+s),(l+s),1}];
vectorsarrows=Table[Arrow[vectors[j,mj,l,s]],{mj,-(l+s),(l+s),1}];
Graphics[
{Text[Style["(Subscript[J, z])",Bold,Large],{-.2,absj}],Black,
Text[Style["|j|="<>ToString@StandardForm[ℏ(Sqrt[j(j+1)])],Bold,Larger],2(vectorjarrows[[-1,1,2]]-vectorjarrows[[-1,1,1]])/3,{-1.3,0.1}],
Text[Style["|s|="<>ToString@StandardForm[ℏ(Sqrt[s(s+1)])],Bold,Larger],vectorlarrows[[-1,1,2]]+(vectorsarrows[[-1,1,2]]-vectorsarrows[[-1,1,1]])/2,{1,-1.3}],
Text[Style["|l|="<>ToString@StandardForm[ℏ(Sqrt[l(l+1)])],Bold,Larger],2(vectorlarrows[[-1,1,2]]-vectorlarrows[[-1,1,1]])/3,{0,1}],
Sequence@@magneticjlabel,
Dashed,Red,Thick,Sequence@@magneticj,
Black,Thick,Dashing[{}],Arrow[{{0,-absj},{0,absj }}],
Circle[{0,0},absj,{-π/2,π/2}],
vectorjarrows,Green,Thin,vectorsarrows,Blue,vectorlarrows
},
AspectRatio->Automatic]

j = l - s

l=1;
s=1/2;
j=l-s;
absj=(Sqrt[j(j+1)])ℏ;
magneticj=Table[Line[{{0,mj},{absj Cos[ArcSin[(mj/absj)]],mj}}],{mj,-(l-s),(l-s),1}];
magneticjlabel=Table[Text[Style[mj "ℏ",FontSize->16],{-0.2,mj}],{mj,-(l-s),(l-s),1}];
vectorjarrows=Table[Arrow[vectorj[j,mj,l,s]],{mj,-(l-s),(l-s),1}];
vectorlarrows=Table[Arrow[vectorl[j,mj,l,s]],{mj,-(l-s),(l-s),1}];
vectorsarrows=Table[Arrow[vectors[j,mj,l,s]],{mj,-(l-s),(l-s),1}];
Graphics[
{Text[Style["(Subscript[J, z])",Bold,Large],{-.2,absj}],
Text[Style["|j|="<>ToString@StandardForm[ℏ(Sqrt[j(j+1)])],Bold,Larger],2(vectorjarrows[[-1,1,2]]-vectorjarrows[[-1,1,1]])/3,{-1.3,0.1}],
Text[Style["|s|="<>ToString@StandardForm[ℏ(Sqrt[s(s+1)])],Bold,Larger],vectorlarrows[[-1,1,2]]+(vectorsarrows[[-1,1,2]]-vectorsarrows[[-1,1,1]])/2,{-1.3,0}],
Text[Style["|l|="<>ToString@StandardForm[ℏ(Sqrt[l(l+1)])],Bold,Larger],2(vectorlarrows[[-1,1,2]]-vectorlarrows[[-1,1,1]])/3,{0,1}],
Sequence@@magneticjlabel,
Dashed,Red,Thick,Sequence@@magneticj,
Black,Thick,Dashing[{}],Arrow[{{0,-absj},{0,absj }}],
Circle[{0,0},absj,{-π/2,π/2}],
vectorjarrows,Thin,Green,vectorlarrows,Blue,vectorsarrows
},
AspectRatio->Automatic]

l = 3, s = 1/2:

j = l + s

l=3;
s=1/2;
j=l+s;
absj=(Sqrt[j(j+1)])ℏ;
magneticj=Table[Line[{{0,mj},{absj Cos[ArcSin[(mj/absj)]],mj}}],{mj,-j,j,1}];
magneticjlabel=Table[Text[Style[mj "ℏ",FontSize->16],{-0.2,mj}],{mj,-j,j,1}];
vectorjdirect=Table[{{0,0},{absj Cos[ArcSin[ℏ mj(1/absj)]],absj Sin[ArcSin[ℏ mj(1/absj)]]}},{mj,-j,j,1}]
vectorjarrows=Table[Arrow[vectorj[j,mj,l,s]],{mj,-j,j,1}];
vectorlarrows=Table[Arrow[vectorl[j,mj,l,s]],{mj,-j,j,1}];
vectorsarrows=Table[Arrow[vectors[j,mj,l,s]],{mj,-j,j,1}];
Graphics[
{Text[Style["(Subscript[J, z])",Bold,Large],{-.2,absj}],
Text[Style["|j|="<>ToString@StandardForm[ℏ(Sqrt[j(j+1)])],Bold,Larger],2(vectorjarrows[[-1,1,2]]-vectorjarrows[[-1,1,1]])/3,{-1.3,0.1}],
Text[Style["|s|="<>ToString@StandardForm[ℏ(Sqrt[s(s+1)])],Bold,Larger],vectorlarrows[[-1,1,2]]+(vectorsarrows[[-1,1,2]]-vectorsarrows[[-1,1,1]])/2,{-1.3,0}],
Text[Style["|l|="<>ToString@StandardForm[ℏ(Sqrt[l(l+1)])],Bold,Larger],2(vectorlarrows[[-1,1,2]]-vectorlarrows[[-1,1,1]])/3,{0,1}],
Sequence@@magneticjlabel,
Dashed,Red,Thick,Sequence@@magneticj,
Black,Thick,Dashing[{}],Arrow[{{0,-absj},{0,absj }}],
Circle[{0,0},absj,{-π/2,π/2}],
vectorjarrows,Thin,Green,vectorlarrows,Blue,vectorsarrows
},
AspectRatio->Automatic]

j=l-s:

l=3;
s=1/2;
j=l-s;
absj=(Sqrt[j(j+1)])ℏ;
magneticj=Table[Line[{{0,mj},{absj Cos[ArcSin[(mj/absj)]],mj}}],{mj,-(l-s),(l-s),1}];
magneticjlabel=Table[Text[Style[mj "ℏ",FontSize->16],{-0.2,mj}],{mj,-(l-s),(l-s),1}];
vectorjdirect=Table[{{0,0},{absj Cos[ArcSin[ℏ mj(1/absj)]],absj Sin[ArcSin[ℏ mj(1/absj)]]}},{mj,-(l-s),(l-s),1}]
vectorJarrows=Table[Arrow[vectorj[l-s,mj,l,s]],{mj,-(l-s),(l-s),1}];
vectorlarrows=Table[Arrow[vectorl[l-s,mj,l,s]],{mj,-(l-s),(l-s),1}];
vectorsarrows=Table[Arrow[vectors[l-s,mj,l,s]],{mj,-(l-s),(l-s),1}];
Graphics[
{Text[Style["(Subscript[J, z])",Bold,Large],{-.2,absj}],
Text[Style["|j|="<>ToString@StandardForm[ℏ(Sqrt[j(j+1)])],Bold,Larger],(vectorjarrows[[-1,1,2]]-vectorjarrows[[-1,1,1]])/2,{-1.3,0.1}],
Text[Style["|s|="<>ToString@StandardForm[ℏ(Sqrt[s(s+1)])],Bold,Larger],vectorlarrows[[-1,1,2]]+(vectorsarrows[[-1,1,2]]-vectorsarrows[[-1,1,1]])/2,{-1.3,0}],
Text[Style["|l|="<>ToString@StandardForm[ℏ(Sqrt[l(l+1)])],Bold,Larger],2(vectorlarrows[[-1,1,2]]-vectorlarrows[[-1,1,1]])/3,{0,1}],
Sequence@@magneticjlabel,
Dashed,Red,Thick,Sequence@@magneticj,
Black,Thick,Dashing[{}],Arrow[{{0,-absj},{0,absj }}],
Circle[{0,0},absj,{-π/2,π/2}],
vectorJarrows,Thin,Green,vectorlarrows,Blue,vectorsarrows
},
AspectRatio->Automatic]

(OverVector[l]) and (OverVector[s]) are rotating about the direction of (OverVector[j]):

ϕ2[jp_,lp_,sp_]:=ArcSin[((Sqrt[sp(sp+1)])/(Sqrt[jp(jp+1)]))Sin[ϕls[jp,lp,sp]]];

Module[{lp,mlp,sp,msp,jp,mjp,lprojectiononj,lx,sprojectiononj,sx,vecj3d},
(* l, s, and j parameters *)
lp=2;
mlp=2;
sp=1/2;
msp=1/2;
jp=5/2;
mjp=5/2;
vecj3d={{0,0,0},{ℏ(Sqrt[jp(jp+1)]) Sin[ϕj[jp,mjp]],0,ℏ(Sqrt[jp(jp+1)]) Cos[ϕj[jp,mjp]]}};
(* projections of l and s on j *)
lprojectiononj=Cos[ϕ2[jp,lp,sp]]ℏ(Sqrt[lp(lp+1)]);
lx=Sin[ϕ2[jp,lp,sp]]ℏ(Sqrt[lp(lp+1)]);
sprojectiononj=Cos[ϕls[jp,lp,sp]-ϕ2[jp,lp,sp]]ℏ(Sqrt[sp(sp+1)]);
sx=Sin[ϕls[jp,lp,sp]-ϕ2[jp,lp,sp]]ℏ(Sqrt[sp(sp+1)]);
Graphics3D[{(* orbital angular momentum *)
Blue,Opacity[0.3],Rotate[ Translate[Cone[lx/2, lprojectiononj/2,30],{0,0,-lprojectiononj/2}],ϕj[jp,mjp]+π,{0,1,0},{0,0,0}],(* spin angular momentum *)
Green,Opacity[0.7],Rotate[ Translate[Cone[sx/2,sprojectiononj/2,50],{0,0,-lprojectiononj-sprojectiononj/2}],ϕj[jp,mjp]+π,{0,1,0},{0,0,0}],
(* total angular momentum *)
Red,Opacity[0.1], Rotate[Translate[Cone[ℏ(Sqrt[jp(jp+1)-(mjp^2)]),ℏ mjp/2,30],{0,0,-ℏ mjp/2}],π,{0,1,0},{0,0,0}],
Opacity[1],Thickness[0.007],Black,Line[vecj3d],
Line[{{0,0,0},{0,0,3.2}}],
Text[Style["Bz",Larger],{0.2,0.2,3}],
Text[Style["(OverVector[L])",Larger],{2,0,0.7}],
Text[Style["(OverVector[S])",Larger],{1,0,0.2}],
Text[Style["(OverVector[J])",Larger],vecj3d[[2]]+{0,0.2,0.2}]
}]]

Magnetfeld - Landé Faktor

Berechnung nach dem Vektormodell :

Es gilt

(Subscript[(OverVector[μ]), j]) = (Subscript[(OverVector[μ]), l])+(Subscript[(OverVector[μ]), s])

Das aus der Vektoraddition resultierende Moment (Subscript[(OverVector[μ]), j]) präzediert um die raumfeste Richtung des Gesamtdrehimpulses (OverVector[j]). Im Zeitmittel bleibt nur die Projektion  des magnetischen Moments (Subscript[μ, J]) auf die die Richtung von (OverVector[j]) -  (Subscript[((Subscript[(OverVector[μ]), j])), j])-übrig und kann beobachtet werden.

Berechnung:

(Subscript[((Subscript[(OverVector[μ]), j])), j]) = |(Subscript[(OverVector[μ]), l])| cos((OverVector[l]),(OverVector[j])) + |(Subscript[(OverVector[μ]), s])| cos((OverVector[s]),(OverVector[j])) = (Subscript[μ, B])(Sqrt[l(l+1)])cos((OverVector[l]),(OverVector[j])) +2(Subscript[μ, B])(Sqrt[s(s+1)])cos((OverVector[s]),(OverVector[j]))

wobei cos((OverVector[s]),(OverVector[j])) und cos((OverVector[l]),(OverVector[j])) wieder aus dem Kosinussatz mit Vektoren der Längen  ℏ(Sqrt[l(l+1)]), ℏ(Sqrt[s(s+1)]) bzw. ℏ(Sqrt[j(j+1)])berechnet werden kann.

cos((OverVector[s]),(OverVector[j])) =((|(OverVector[l])((|)^2)-|(OverVector[s])(|^2)-|(OverVector[j])(|^2))/(2 |(OverVector[j])| |(OverVector[s])|))=((l(l+1)-s(s+1)-j(j+1))/(2(Sqrt[j(j+j) s(s+1)])))

cos((OverVector[l]),(OverVector[j])) =((|(OverVector[s])((|)^2)-|(OverVector[l])(|^2)-|(OverVector[j])(|^2))/(2 |(OverVector[j])| |(OverVector[l])|))=((s(s+1)-l(l+1)-j(j+1))/(2(Sqrt[j(j+j) l(l+1)])))

und damit

((l(l+1)-s(s+1)-j(j+1))/(2(Sqrt[j(j+j)])))

|(Subscript[((Subscript[(OverVector[μ]), j])), j])| = ||(Subscript[(OverVector[μ]), l])| cos((OverVector[l]),(OverVector[j])) + |(Subscript[(OverVector[μ]), s])| cos((OverVector[s]),(OverVector[j]))| = |(Subscript[μ, B])(Sqrt[l(l+1)])((s(s+1)-l(l+1)-j(j+1))/(2(Sqrt[j(j+j) l(l+1)]))) +2(Subscript[μ, B])(Sqrt[s(s+1)])((l(l+1)-s(s+1)-j(j+1))/(2(Sqrt[j(j+j) s(s+1)])))| = |(Subscript[μ, B])(((s(s+1)-l(l+1)-j(j+1))/(2(Sqrt[j(j+j)])))+((l(l+1)-s(s+1)-j(j+1))/(Sqrt[j(j+j)])))| =

=(Subscript[μ, B])((3j(j+1)-l(l+1)+s(s+1))/(2(Sqrt[j(j+j)])))

Schliesslich :

|(Subscript[((Subscript[(OverVector[μ]), j])), j])|=(Subscript[μ, B])(Subscript[g, j])(Sqrt[j(j+1)])

mit

(Subscript[g, j])=1+((j(j+1)-l(l+1)+s(s+1))/(2j(j+j)))

(Subscript[g, j])... Landefaktor

Z - Komponente des magnetischen Moments :

(Subscript[((Subscript[(OverVector[μ]), j])), j,z]) =-(Subscript[g, j])(Subscript[μ, B])(Subscript[m, j])

gj[j_,l_,s_]:=1+((j(j+1)+s(s+1)-l(l+1))/(2 j(j+1)))

j = 3/2, l = 1, s = 1/2 :

gj[3/2,1,1/2]
gj[1/2,1,1/2]

Many- Electron-Systems (LS Coupling)

LS - Coupling :

If the spin-orbit interaction of the individual electrons ((Subscript[(OverVector[s]), i]).(Subscript[(OverVector[l]), i])) is weaker than the interaction
of the orbital angular momenta ((Subscript[(OverVector[l]), i]).(Subscript[(OverVector[l]), j])) or the spin angular momenta ((Subscript[(OverVector[s]), i]).(Subscript[(OverVector[s]), j]))of different electrons the orbital
angular momenta  vectors (Subscript[(OverVector[l]), i])re added to the total orbital angular momentum (OverVector[L])= (∑_i)(Subscript[(OverVector[l]), i]) and the spins (Subscript[(OverVector[s]), i]) to the total spin (OverVector[S])= (∑_i)(Subscript[(OverVector[s]), i]).

2 - electron system :

(OverVector[L])=(Subscript[(OverVector[l]), 1])+(Subscript[(OverVector[l]), 2])

For the absolute value |(OverVector[L])|=ℏ(Sqrt[L(L+1)]), where L can have values  (Subscript[l, 1])+(Subscript[l, 2]),(Subscript[l, 1])+(Subscript[l, 2])-1,...,(Subscript[l, 1])-(Subscript[l, 2])

Similar for the spins :

(OverVector[S])=(Subscript[(OverVector[s]), 1])+(Subscript[(OverVector[s]), 2])

with |(OverVector[S])|=ℏ(Sqrt[S(S+1)])with S=0 or S=1.

The total angular momentum is the vector sum of (OverVector[L]) and (OverVector[S])

(OverVector[J]) = (OverVector[S]) + (OverVector[L])

with |(OverVector[J])|=ℏ(Sqrt[J(J+1)]). The quantum number J can have values

J=L (for S=0) or
J=L+1,L,L-1 for (S=1)

Construct vectors :

vectortot[J_,mJ_,L_,S_]:={{0,0},U[ϕjconstr[J,mJ,L,S]].({(Sqrt[L(L+1)]),0}+U[ϕls[J,L,S]].{(Sqrt[S(S+1)]),0})};
vector1[Jp_,mJp_,Lp_,Sp_]:={{0,0},U[ϕjconstr[Jp,mJp,Lp,Sp]].{(Sqrt[Lp(Lp+1)]),0}}
vector2[Jp_,mJp_,Lp_,Sp_]:={U[ϕjconstr[Jp,mJp,Lp,Sp]].{(Sqrt[Lp(Lp+1)]),0},U[ϕjconstr[Jp,mJp,Lp,Sp]].{(Sqrt[Lp(Lp+1)]),0}+U[ϕjconstr[Jp,mJp,Lp,Sp]].((Sqrt[Sp(Sp+1)]){Cos[ϕls[Jp,Lp,Sp]],-Sin[ϕls[Jp,Lp,Sp]]})}

spin coupling :

S1=1/2;
S2=1/2;
magneticS=Table[Line[{{0,mS},{vectortot[mS,mS,S1,S2][[2,1]],mS}}],{mS,S1-S2,S1+S2,1}];
magneticSlabel=Table[Text[Style[mS "ℏ",FontSize->16],{-0.2,mS}],{mS,S1-S2,S1+S2,1}];
vectorSarrows=Table[Arrow[vectortot[mS,mS,S1,S2]],{mS,S1-S2,S1+S2,1}];
vectorS1arrows=Table[Arrow[vector1[mS,mS,S1,S2]],{mS,S1-S2,S1+S2,1}];
vectorS2arrows=Table[Arrow[vector2[mS,mS,S1,S2]],{mS,S1-S2,S1+S2,1}];
slabel=Table[Text[Style["(OverVector[S]) ((Subscript[m, S]) = "<>ToString[mS]<>")",Larger],vectortot[mS,mS,S1,S2][[2]]+{0.25,0.05}],{mS,S1-S2,S1+S2,1}];
Graphics[
{Text[Style["(Subscript[S, z])",Bold,Large],{-.2,S1+S2+0.2}],
Sequence@@magneticSlabel,
Dashed,Red,Thick,Sequence@@magneticS,
Black,Thin,Dashing[{}],Arrow[{{0,S1-S2},{0,S1+S2+0.2}}],Thick,
vectorS1arrows,Green,Thick,Thin,vectorS2arrows,Blue,vectorSarrows,Black,
slabel
},
AspectRatio->Automatic,PlotRange->All]

orbital angular momentum coupling :

L1=1;
L2=1;
magneticL=Table[Line[{{0,mL},{vectortot[mL,mL,L1,L2][[2,1]],mL}}],{mL,L1-L2,L1+L2,1}];
magneticLlabel=Table[Text[Style[mL "ℏ",FontSize->16],{-0.2,mL}],{mL,L1-L2,L1+L2,1}];
vectorLarrows=Table[Arrow[vectortot[mL,mL,L1,L2]],{mL,L1-L2,L1+L2,1}];
vectorL1arrows=Table[Arrow[vector1[mL,mL,L1,L2]],{mL,L1-L2,L1+L2,1}];
vectorL2arrows=Table[Arrow[vector2[mL,mL,L1,L2]],{mL,L1-L2,L1+L2,1}];
slabel=Table[Text[Style["(OverVector[L]) ((Subscript[m, L]) = "<>ToString[mL]<>")",Larger],vectortot[mL,mL,L1,L2][[2]]+{0.25,0.05}],{mL,L1-L2,L1+L2,1}];
Graphics[
{Text[Style["(Subscript[L, z])",Bold,Large],{-.2,L1+L2+0.2}],
Sequence@@magneticLlabel,
Dashed,Red,Thick,Sequence@@magneticL,
Black,Thin,Dashing[{}],Arrow[{{0,L1-L2},{0,L1+L2+0.2}}],Thick,
vectorL1arrows,Green,Thick,Thin,vectorL2arrows,Blue,vectorLarrows,Black,
slabel
},
AspectRatio->Automatic,PlotRange->All]

(^3)(Subscript[P, 0,1,2]): L = 1, S = 1 (spin triplet),  mJ = (Subscript[mJ, max]):

L=1;
S=1;
magneticJ=Table[Line[{{0,mJ},{vectortot[mJ,mJ,L,S][[2,1]],mJ}}],{mJ,L-S,L+S,1}];
magneticJlabel=Table[Text[Style[mJ "ℏ",FontSize->16],{-0.2,mJ}],{mJ,L-S,L+S,1}];
vectorJarrows=Table[Arrow[vectortot[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
vectorLarrows=Table[Arrow[vector1[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
vectorSarrows=Table[Arrow[vector2[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
jlabel=Table[Text[Style["(OverVector[J]) ((Subscript[m, J]) = "<>ToString[mJ]<>")",Larger],vectortot[mJ,mJ,L,S][[2]]+{0.45,0.1}],{mJ,L-S,L+S,1}];
Graphics[
{Text[Style["(Subscript[J, z])",Bold,Large],{-.2,L+S+0.2}],
Sequence@@magneticJlabel,
Dashed,Red,Thick,Sequence@@magneticJ,
Black,Thin,Dashing[{}],Arrow[{{0,L-S},{0,L+S+0.2 }}],Thick,
vectorJarrows,Green,Thick,Thin,vectorLarrows,Blue,vectorSarrows,Black,
jlabel
},
AspectRatio->Automatic,PlotRange->All]

(^1)(Subscript[P, 1]): L = 1, S = 0 (Singlet),  mJ = (Subscript[mJ, max]):

L=1;
S=0;
magneticJ=Table[Line[{{0,mJ},{vectortot[mJ,mJ,L,S][[2,1]],mJ}}],{mJ,L-S,L+S,1}];
magneticJlabel=Table[Text[Style[mJ "ℏ",FontSize->16],{-0.2,mJ}],{mJ,L-S,L+S,1}];
vectorJarrows=Table[Arrow[vectortot[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
vectorLarrows=Table[Arrow[vector1[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
vectorSarrows=Table[Arrow[vector2[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
jlabel=Table[Text[Style["(OverVector[J]) ((Subscript[m, J]) = "<>ToString[mJ]<>")",Larger],vectortot[mJ,mJ,L,S][[2]]+{0.2,0.0}],{mJ,L-S,L+S,1}];
Graphics[
{Text[Style["(Subscript[J, z])",Bold,Large],{-.2,L+S+0.2}],
Sequence@@magneticJlabel,
Dashed,Red,Thick,Sequence@@magneticJ,
Black,Thin,Dashing[{}],Arrow[{{0,Min[0,L-S]},{0,L+S+0.2 }}],Thick,
vectorJarrows,Green,Thick,Thin,vectorLarrows,Blue,vectorSarrows,
Black,jlabel},
AspectRatio->Automatic,PlotRange->All]

(^3)(Subscript[D, 1,2,3]): L = 2, S = 1,  mJ = (Subscript[mJ, max]):

L=2;
S=1;
magneticJ=Table[Line[{{0,mJ},{vectortot[mJ,mJ,L,S][[2,1]],mJ}}],{mJ,L-S,L+S,1}];
magneticJlabel=Table[Text[Style[mJ "ℏ",FontSize->16],{-0.2,mJ}],{mJ,L-S,L+S,1}];
vectorJarrows=Table[Arrow[vectortot[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
vectorLarrows=Table[Arrow[vector1[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
vectorSarrows=Table[Arrow[vector2[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
jlabel=Table[Text[Style["(OverVector[J]) ((Subscript[m, J]) = "<>ToString[mJ]<>")",Larger],vectortot[mJ,mJ,L,S][[2]]+{0.3,0.0}],{mJ,L-S,L+S,1}];
Graphics[
{Text[Style["(Subscript[J, z])",Bold,Large],{-.2,L+S+0.2}],
Sequence@@magneticJlabel,
Dashed,Red,Thick,Sequence@@magneticJ,
Black,Thin,Dashing[{}],Arrow[{{0,Min[0,L-S]},{0,L+S+0.2 }}],Thick,
vectorJarrows,Green,Thick,Thin,vectorLarrows,Blue,vectorSarrows,
Black,jlabel},
AspectRatio->Automatic,PlotRange->All]

(^7)(Subscript[F, 0,1,2,3,4,5,6]): L = 3, S = 3 (at least six electrons) (mJ = (Subscript[mJ, max]))

L=3;
S=3;
magneticJ=Table[Line[{{0,mJ},{vectortot[mJ,mJ,L,S][[2,1]],mJ}}],{mJ,L-S,L+S,1}];
magneticJlabel=Table[Text[Style[mJ "ℏ",FontSize->16],{-0.2,mJ}],{mJ,L-S,L+S,1}];
vectorJarrows=Table[Arrow[vectortot[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
vectorLarrows=Table[Arrow[vector1[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
vectorSarrows=Table[Arrow[vector2[mJ,mJ,L,S]],{mJ,L-S,L+S,1}];
jlabel=Table[Text[Style["(OverVector[J]) ((Subscript[m, J]) = "<>ToString[mJ]<>")",Larger],vectortot[mJ,mJ,L,S][[2]]+{0.55,0.1}],{mJ,L-S,L+S,1}];
Graphics[
{Text[Style["(Subscript[J, z])",Bold,Large],{-.2,L+S+0.2}],
Sequence@@magneticJlabel,
Dashed,Red,Thick,Sequence@@magneticJ,
Black,Thin,Dashing[{}],Arrow[{{0,Min[0,L-S]},{0,L+S+0.2 }}],Thick,
vectorJarrows,Green,Thick,Thin,vectorLarrows,Blue,vectorSarrows,
Black,jlabel},
AspectRatio->Automatic,PlotRange->All]

(^7)(Subscript[F, 0,1,2,3,4,5,6]): L = 3, S = 3 (mJ = (Subscript[mJ, max])-1)

L=3;
S=3;
magneticJ=Table[Line[{{0,mJ-1},{vectortot[mJ,Max[0,mJ-1],L,S][[2,1]],mJ-1}}],{mJ,L-S+1,L+S,1}];
magneticJlabel=Table[Text[Style[mJ "ℏ",FontSize->16],{-0.2,mJ}],{mJ,L-S,L+S,1}];
vectorJarrows=Table[Arrow[vectortot[mJ,Max[0,mJ-1],L,S]],{mJ,L-S,L+S,1}];
vectorLarrows=Table[Arrow[vector1[mJ,Max[0,mJ-1],L,S]],{mJ,L-S,L+S,1}];
vectorSarrows=Table[Arrow[vector2[mJ,Max[0,mJ-1],L,S]],{mJ,L-S,L+S,1}];
jlabel=Table[Text[Style["(OverVector[J]) ((Subscript[m, J]) = "<>ToString[mJ-1]<>")",Larger],vectortot[mJ,Max[0,mJ-1],L,S][[2]]+{0.55,0.1}],{mJ,L-S+1,L+S,1}];
Graphics[
{Text[Style["(Subscript[J, z])",Bold,Large],{-.2,L+S+0.2}],
Sequence@@magneticJlabel,
Dashed,Red,Thick,magneticJ,
Black,Thin,Dashing[{}],Arrow[{{0,Min[0,L-S]},{0,L+S+0.2 }}],jlabel,Thick,
vectorJarrows,Green,Thick,Thin,vectorLarrows,Blue,vectorSarrows},
AspectRatio->Automatic,PlotRange->All]

(^7)(Subscript[F, 0,1,2,3,4,5,6]): L = 3, S = 3 (mJ = 0)

L=3;
S=3;
magneticJ=Table[Line[{{mJ,-0.2},{vectortot[mJ,0,L,S][[2,1]],mJ}}],{mJ,L-S,L+S,1}];
magneticJlabel=Table[Text[Style[mJ "ℏ",FontSize->16],{-0.2,mJ}],{mJ,L-S,L+S,1}];
vectorJarrows=Table[Arrow[vectortot[mJ,0,L,S]],{mJ,L-S,L+S,1}];
vectorLarrows=Table[Arrow[vector1[mJ,0,L,S]],{mJ,L-S,L+S,1}];
vectorSarrows=Table[Arrow[vector2[mJ,0,L,S]],{mJ,L-S,L+S,1}];
jlabel=Text[Style["(OverVector[J]) ((Subscript[m, J]) = "<>ToString[0]<>")",Larger],vectortot[6,0,L,S][[2]]+{-0.2,-0.2}];
Graphics[
{Text[Style["(Subscript[J, z])",Bold,Large],{-.3,L+S+0.4}],magneticJlabel,
Dashed,Red,Thick,
Black,Thin,Dashing[{}],Arrow[{{0,Min[0,L-S]},{0,L+S+0.2 }}],jlabel,Thick,
vectorJarrows,Green,Thick,Thin,vectorLarrows,Blue,vectorSarrows},
AspectRatio->Automatic,PlotRange->All]