***This notebook has expressions needed in the appendix of Chapter 18.  This notebook calculates the diffusion coefficient for a 0 to 1 transition***

<<c:\pberman\mathematica\5.2\clebsh.m

<<c:\pberman\mathematica\5.2\threej.m

<<c:\pberman\mathematica\5.2\ninej.m

<<c:\pberman\mathematica\5.2\sixj.m

<<c:\pberman\mathematica\5.2\prate.m

sq[x_]:=Sqrt[2 x+1]

B[K_]:=Sqrt[16 Pi/3]kron[K,0]+Sqrt[8 Pi/15] kron[K,2]

(Subscript[γ, HG])=2 γ

kron[G_,G1_]:=If[G==G1,1,0]

A[K_,Kp_,Kt_,Kb_,Kbp_,G_,H_]:=Sum[(2 x+1)sixj[{K,Kbp},{Kp,Kb},{Kt,x} ] nj[{K,x,Kb},{G,H,1},{G,H,1}]nj[{x,Kp,Kbp},{H,G,1},{H,G,1}],{x,Abs[K-Kb],K+Kb}]

T[K_,Kp_,Kt_,Kb_,Kbp_,G_,H_]:=3 (-1)^(1+Kb+Kp) B[Kb] sq[H]^2 sq[K] sq[Kp] sq[Kt] sq[Kb] sq[Kbp](Subscript[γ, HG]) χ^2((γ^2)+(δ^2))^(-1) A[K,Kp,Kt,Kb,Kbp,G,H]

S[K_,Kp_,Kb_,H_,G_]:=3 (-1)^(1+Kb+K)  sq[K] sq[Kp]  sq[Kb] (Subscript[γ, HG]) χ^2((γ^2)+(δ^2))^(-1) nj[{K,Kp,Kb},{H,G,1},{H,G,1}]

Sp[K_,Kp_,Kb_,G_,H_]:=-3 (-1)^(H-G+Kb)  sq[K] sq[Kp]  sq[Kb]  χ^2(γ-I δ)^(-1) sixj[{K,G},{Kp,G},{Kb,G}]sixj[{1,G},{1,G},{Kb,H}]

Sm[K_,Kp_,Kb_,G_,H_]:=-3 (-1)^(H-G+Kp+K)  sq[K] sq[Kp]  sq[Kb]  χ^2(γ+I δ)^(-1) sixj[{K,G},{Kp,G},{Kb,G}]sixj[{1,G},{1,G},{Kb,H}]

λ[th_,ph_,Kb_,Kbp_,j_,jp_,Kt_,Qt_]:=(-1)^(Kb+Kbp+Qt)sq[Kt] Sum[T3[{Kb,Qt-Qbp},{Kbp,Qbp},{Kt,-Qt} ] SphericalHarmonicY[Kb,Qt-Qbp,th,ph]ϵ[Kbp,Qbp,j,jp],{Qbp,-Kbp,Kbp}]

interm[K_,Q_,G_,H_,th_,ph_,p_,pp_]:=Sum[(-1)^Qp T3[{K,Q},{Kp,-Qp},{Kt,Qp-Q} ] T[K,Kp,Kt,Kb,Kbp,G,H]λ[th,ph,Kb,Kbp,j,jp,Kt,Qp-Q]ρ[G,p+(k-k[j]),pp+k-k[jp],Kp,Qp],{Kt,Abs[K-Kp],K+Kp} ,{Kb,0,2}, {Kbp,0,2},{Kp,0,2 G},{Qp,-Kp,Kp},{j,1,2},{jp,1,2}]

interm[K_,Q_,Kp_,Qp_,G_,H_,th_,ph_,p_,pp_]:=Sum[(-1)^Qp T3[{K,Q},{Kp,-Qp},{Kt,Qp-Q} ] T[K,Kp,Kt,Kb,Kbp,G,H]λ[th,ph,Kb,Kbp,j,jp,Kt,Qp-Q]ρ[G,p+(k-k[j]),pp+k-k[jp],Kp,Qp],{Kt,Abs[K-Kp],K+Kp} ,{Kb,0,2}, {Kbp,0,2},{j,1,2},{jp,1,2}]

outterm[K_,Q_,Kp_,Qp_,G_,H_,p_,pp_]:=Sum[(-1)^Qp T3[{K,Q},{Kp,-Qp},{Kt,Qp-Q} ] ϵ[Kt,Qp-Q,j,jp](Sp[K,Kp,Kt,G,H]ρ[G,p,pp+k[j]-k[jp],Kp,Qp]+Sm[K,Kp,Kt,G,H]ρ[G,p-k[j]+k[jp],pp,Kp,Qp]),{Kt,Abs[K-Kp],K+Kp} ,{j,1,2},{jp,1,2}]

intermavg[K_,Q_,Kp_,Qp_,G_,H_,p_,pp_]:=(3/(8 Pi))Integrate[Sin[th]interm[K,Q,Kp,Qp,G,H,th,ph,p,pp],{th,0,Pi},{ph,0,2 Pi}]

**  ϵ(K,Q) for x polarized light**

ϵ[K_,Q_,a_,b_]:=-kron[K,0] kron[Q,0]/(Sqrt[3])+kron[K,2] (-kron[Q,0]/(Sqrt[6])+(kron[Q,2]+kron[Q,-2])/2)

ϵ[0,0,2,1]

k[1]=k0

k[2]=-k0

***now go to FP  description***

infp[K_,Q_,Kp_,Qp_,G_,H_,th_,ph_,z_,p_,hb_]:=Sum[(-1)^Qp T3[{K,Q},{Kp,-Qp},{Kt,Qp-Q} ] T[K,Kp,Kt,Kb,Kbp,G,H]λ[th,ph,Kb,Kbp,j,jp,Kt,Qp-Q]ρ[G,z,p+hb (k-(k[jp]+k[j])/2),Kp,Qp] Exp[I(k[j]-k[jp])z],{Kt,Abs[K-Kp],K+Kp} ,{Kb,0,2}, {Kbp,0,2},{j,1,2},{jp,1,2}]

infpav[K_,Q_,Kp_,Qp_,G_,H_,z_,p_,hb_]:=(3/(8 Pi))Integrate[Sin[th]infp[K,Q,Kp,Qp,G,H,th,ph,z,p,hb],{th,0,Pi},{ph,0,2 Pi}]

outfp[K_,Q_,Kp_,Qp_,G_,H_,z_,p_,hb_]:=Sum[(-1)^Qp T3[{K,Q},{Kp,-Qp},{Kt,Qp-Q} ] ϵ[Kt,Qp-Q,j,jp](Sp[K,Kp,Kt,G,H]ρ[G,z,p+hb(k[j]-k[jp])/2,Kp,Qp]Exp[I(k[j]-k[jp])z]+Sm[K,Kp,Kt,G,H]ρ[G,z,p-hb(k[j]-k[jp])/2,Kp,Qp]Exp[I(k[j]-k[jp])z]),{Kt,Abs[K-Kp],K+Kp} ,{j,1,2},{jp,1,2}]

Series[ρ[G,z,p+hb (k-(k[jp]+k[j])/2),Kp,Qp] ,{hb,0,2}]

Series[ρ[G,z,p+hb(k[j]-k[jp])/2,Kp,Qp] ,{hb,0,2}]

Series[ρ[G,z,p-hb(k[j]-k[jp])/2,Kp,Qp] ,{hb,0,2}]

**hbar term**

infphb[K_,Q_,Kp_,Qp_,G_,H_,th_,ph_,z_,p__]:=Sum[(-1)^Qp T3[{K,Q},{Kp,-Qp},{Kt,Qp-Q} ] T[K,Kp,Kt,Kb,Kbp,G,H]λ[th,ph,Kb,Kbp,j,jp,Kt,Qp-Q](k0 Cos[th]-((k[j])/2)-((k[jp])/2))Exp[I(k[j]-k[jp])z],{Kt,Abs[K-Kp],K+Kp} ,{Kb,0,2}, {Kbp,0,2},{j,1,2},{jp,1,2}]

infpavhb[K_,Q_,Kp_,Qp_,G_,H_,z_,p_]:=(3/(8 Pi))Integrate[Sin[th]infphb[K,Q,Kp,Qp,G,H,th,ph,z,p],{th,0,Pi},{ph,0,2 Pi}]

outfphb[K_,Q_,Kp_,Qp_,G_,H_,z_,p_]:=Sum[(-1)^Qp T3[{K,Q},{Kp,-Qp},{Kt,Qp-Q} ] ϵ[Kt,Qp-Q,j,jp](Sp[K,Kp,Kt,G,H](1/2) (k[j]-k[jp])Exp[I(k[j]-k[jp])z]-Sm[K,Kp,Kt,G,H](1/2) (k[j]-k[jp])Exp[I(k[j]-k[jp])z]),{Kt,Abs[K-Kp],K+Kp} ,{j,1,2},{jp,1,2}]

Simplify[outfphb[0,0,0,0,0,1,z,p]+infpavhb[0,0,0,0,0,1,z,p]]

** this is the gradient friction force (the spatially averaged friction force vanishes) for a J=0 ground state***

*** hbar squared term***

infphbsq[K_,Q_,Kp_,Qp_,G_,H_,th_,ph_,z_,p_]:=Sum[(-1)^Qp T3[{K,Q},{Kp,-Qp},{Kt,Qp-Q} ] T[K,Kp,Kt,Kb,Kbp,G,H]λ[th,ph,Kb,Kbp,j,jp,Kt,Qp-Q]((1/8) (((2 k0 Cos[th]-k[j]-k[jp]))^2))Exp[I(k[j]-k[jp])z],{Kt,Abs[K-Kp],K+Kp} ,{Kb,0,2}, {Kbp,0,2},{j,1,2},{jp,1,2}]

infpavhbsq[K_,Q_,Kp_,Qp_,G_,H_,z_,p_]:=(3/(8 Pi))Integrate[Sin[th]infphbsq[K,Q,Kp,Qp,G,H,th,ph,z,p],{th,0,Pi},{ph,0,2 Pi}]

outfphbsq[K_,Q_,Kp_,Qp_,G_,H_,z_,p_]:=Sum[(-1)^Qp T3[{K,Q},{Kp,-Qp},{Kt,Qp-Q} ] ϵ[Kt,Qp-Q,j,jp](Sp[K,Kp,Kt,G,H](1/8) (((k[j]-k[jp]))^2) Exp[I(k[j]-k[jp])z]+Sm[K,Kp,Kt,G,H](1/8) (((k[j]-k[jp]))^2) Exp[I(k[j]-k[jp])z]),{Kt,Abs[K-Kp],K+Kp} ,{j,1,2},{jp,1,2}]

Simplify[outfphbsq[0,0,0,0,0,1,z,p]+infpavhbsq[0,0,0,0,0,1,z,p]]

** the spatially averaged diffusion coeeficient is (( 14  (k0^2) γ (χ^2))/(5 ((γ^2)+(δ^2))))for a J=0 ground state***

**now take z polarized radiation and change cosθ to sinθsinϕ for propagation along y**

ϵ[K_,Q_,a_,b_]:=-kron[K,0] kron[Q,0]/(Sqrt[3])+kron[K,2] (kron[Q,0](Sqrt[2/3]))

infphbsq[K_,Q_,Kp_,Qp_,G_,H_,th_,ph_,z_,p_]:=Sum[(-1)^Qp T3[{K,Q},{Kp,-Qp},{Kt,Qp-Q} ] T[K,Kp,Kt,Kb,Kbp,G,H]λ[th,ph,Kb,Kbp,j,jp,Kt,Qp-Q]((1/8) (((2 k0 Sin[th]Sin[ph]-k[j]-k[jp]))^2))Exp[I(k[j]-k[jp])z],{Kt,Abs[K-Kp],K+Kp} ,{Kb,0,2}, {Kbp,0,2},{j,1,2},{jp,1,2}]

Simplify[outfphbsq[0,0,0,0,0,1,z,p]+infpavhbsq[0,0,0,0,0,1,z,p]]

**same diffusion coefficient, as expected***