Symbolic Computing Package and
Its Application to Mathematical Physics

Youngjoo Chung

School of Information and Communications, Gwangju Institute of Science and Technology (GIST), Korea

Keywords

Notation,
Manipulation,
&
Evaluation
of Mathematical Expressions

Notations Using the Traditional Form

Notations of the traditional form for derivatives, integrals, sums, products, vector operators, etc., are used in the Symbolic Computing package.

Implemented using the low-level box language

MakeBoxes, MakeExpression, ⋯
To be distinguished from the implementation using the Notation Package.

Delayed on-demand evaluation

SCEvalDeriv for evaluation of derivatives
SCEvalInt, SCEvalSum, SCEvalProd for evaluation of integrals, sums and products.

Advantages

Improved readability
Better, precisely controlled manipulation of mathematical expressions

Notations

Derivatives

Mathematica native form

{D[f[x,y],x],D[f[x,y],x,{y,2}],D[D[f[x,y],{y,2}],x],Dt[f[t],t],Dt[f[x,t],t]}

The new notation using the tranditional form

{((∂f[x,y])/(∂x)),(((∂^2)f)/(∂x∂y)),(((∂^3)f)/(∂x∂(y^2))),(∂/(∂x))(((∂^2)f)/(∂(y^2))),((\[DifferentialD]f)/(\[DifferentialD]t)),(((\[DifferentialD]^2)f)/(\[DifferentialD](t^2)))}

Vector operators

{∇ψ,∇·(OverVector[A]),∇\[Cross](OverVector[A]),(∇^2)ψ,(∇^2)(OverVector[A]),(OverVector[a]).∇ψ}

{(Subscript[∇, (OverVector[x])])ψ,(Subscript[∇, (OverVector[x])])·(OverVector[A]),(Subscript[∇, (OverVector[x])])\[Cross](OverVector[A]),(Subscript[∇, (OverVector[x])]^2)ψ,(Subscript[∇, (OverVector[x])]^2)(OverVector[A]),(OverVector[a]).(Subscript[∇, (OverVector[x])])ψ}

Integrals, sums and products

{∫f\[DifferentialD]x,(∫_a^b)f\[DifferentialD]x,∮ψ\[DifferentialD]q,∮(OverVector[A]).(OverVector[n])\[DifferentialD]a,∮(OverVector[A]).(OverHat[t])\[DifferentialD]l}

{(∑_(n=1)^N)(Subscript[a, n]),(∑_n)(Subscript[a, n]),(∑_(n=1)^10)(n^2)}

{(∏_(n=1)^N)(Subscript[a, n]),(∏_n)(Subscript[a, n]),(∏_(n=1)^10)(n^2)}

Bras, kets and brakets

{⟨α|,|β⟩,⟨α|β⟩,⟨α|A|β⟩}

{⟨α(Subscript[|, 1]),(Subscript[|β⟩, 1]),(Subscript[⟨α|β⟩, 1]),(Subscript[⟨α|A|β⟩, 1])}

Extended superscripts and subsuperscripts

{(SuperscriptList[A, -1]),(SuperscriptList[T, α,β]),(SubsuperscriptList[S, 1, m,n])}

Some examples of the symbolic algebra using the traditional notation

SCMergeDerivs[(((∂^2)f)/(∂x∂y))+((∂g)/(∂y))]

SCMergeDerivs[((a f'))'+((a ((g')^2)))',Prime->x]

SCEvalDeriv[((\[DifferentialD]^2)/(\[DifferentialD](t^2)))((OverVector[A])[t]\[Cross](OverVector[B])[t])]

SCDerivExpand[(∂/(∂x))(((f+Sin[g])/h)),{f,g,h}]

SCDerivSimp[g h (((\[DifferentialD]^2)f)/(\[DifferentialD](x^2)))+2 h ((\[DifferentialD]f)/(\[DifferentialD]x)) ((\[DifferentialD]g)/(\[DifferentialD]x))+f h (((\[DifferentialD]^2)g)/(\[DifferentialD](x^2)))+2 g ((\[DifferentialD]f)/(\[DifferentialD]x)) ((\[DifferentialD]h)/(\[DifferentialD]x))+2 f ((\[DifferentialD]g)/(\[DifferentialD]x)) ((\[DifferentialD]h)/(\[DifferentialD]x))+f g (((\[DifferentialD]^2)h)/(\[DifferentialD](x^2)))]

SCFourierToDiracDelta[∫(E^(I (OverVector[k]).(OverVector[z])))\[DifferentialD](z^3),(z^3)]

SCCombInts[∫x (((∫f[x]\[DifferentialD]x))^3)\[DifferentialD]x,ReplVar->{x,u,v,w}]

SCEvalIntResidue[(∫_(-∞)^∞)(1/(x(x-I)))\[DifferentialD]x,{0,-(1/2)}]

SCIntByParts[(∫_(-∞)^x)ψ'[y](y^2)\[DifferentialD]y,ψ'[y]->ψ[y]]

SCCombSums[(∑_(n=1)^∞)(Subscript[f, n])∘(∑_(m=1)^∞)(Subscript[g, m])]

SCBraketExpand[⟨α|∘A∘(a|ψ⟩+b|ϕ⟩),A]

Manipulation of Mathematical Expressions

Mathematica provides a solid foundation for symbolic computing and a number of supporting functions.

Built-in kernel functions - Apart, Factor, Simplify, TrigToExp, …

A mechanism is needed to facilitate the algebraic manipulation of mathematical expressions with the following properties:

Seamless integration with the computing environment of Mathematica
Selective targeting of the object to apply functions
Improved handling of subscripts ((Subscript[a, 1])), tildes (ã), hats (â), etc.
Addition of comments
Improved handling of derivatives, integrals, summations and products
Minimal use of variables

Algebraic manipulation of formulas using symbolic computing

Mathematica is not a word processor or an equation editor.
Application of functions
Substitution using mathematical identities
Allows focusing on the principles instead of time-consuming and error-prone calculations.
Good readability
Minimization of human errors during calculations
Expressions that closely resemble the traditional mathematical style, e.g., subscripts and vector notations

Over 500 user-defined functions in the Symbolic Computing package (SymbolicComputing.m) in the following categories:

Basic Algebra 
Complex Variables 
Differential Calculus  
Display and Graphics 
Elementary Functions 
Equation Solving 
Equations 
Export of Data 
Flow Control 
Formula Manipulation 
Fourier Analysis 
Function Analysis 
Geometry 
Integral Calculus 
Numerical Functions 
Operator Analysis 
Patterns 
Polynomials and Series 
Products 
Rules 
Special Functions 
String Operations 
Summations 
Symbols 
Trigonometric Functions 
Variables 
Vectors and Matrices

Concepts

User-defined functions

The function names start with the prefix SC.
Algebraic manipulation of expressions
Mathematical identities

SCMAF

An abbreviation of SCMapApplyFunctions
The platform for algebraic manipulation of all or parts of an expression
Sequential execution of built-in or user-defined functions for step-by-step controlled
User-defined functions can be used separately independent of the macro SCMAF, in which case the features provided by the options of SCMAF cannot be used.

The syntax

SCMAF[expr,
	(Subscript[f, 1]), {(Subscript[x, 11]), (Subscript[x, 12]), …}, (Subscript[lopts, 1]),
	(Subscript[f, 2]), {(Subscript[x, 21]), (Subscript[x, 22]), …}, (Subscript[lopts, 2]),
	…,
	gopts

]
(Subscript[f, 1]), (Subscript[f, 2]), … : functions to operate on the expressions in sequence
{(Subscript[x, 11]), (Subscript[x, 12]), …}, {(Subscript[x, 21]), (Subscript[x, 22]), …}, … : arguments list
By default, the first arguments (Subscript[x, 11]), (Subscript[x, 21]), … are replaced according to:
	(Subscript[x, 11])->(Subscript[f, 1])[(Subscript[x, 11]),(Subscript[x, 12]),…], (Subscript[x, 21])->(Subscript[f, 2])[(Subscript[x, 21]),(Subscript[x, 22]),…], etc.
	The MainArg local option can be used to change the main argument.
Simple substitutions are done using ReplaceAll for (Subscript[f, n]).
The result from (Subscript[f, 1]) is passed onto (Subscript[f, 2]), etc.
The execution is terminated on encountering an Exit command.
The first arguments (Subscript[x, n1]) must be all or part of the result returned by the previous function (Subscript[f, n-1]).
(Subscript[x, n1]) can be a pattern.
(Subscript[x, n1]) can be given in the form All or At[pos], in which case the function (Subscript[f, n]) is applied only to the specified position.
If (Subscript[x, n1]) is set to All, (Subscript[f, n]) is applied to the entire expression.
(Subscript[lopts, n]) and gopts are the local and global options, respectively.

Basic Algebra

Binomial expansion

SCBinomialExpand[(((x+a))^n),k]
SCEvalSum[%]

SCBinomialExpand[(((a+b+c))^n),k,l]
SCEvalSum[%]//PowerExpand

Factoring

SCFactor[a+b,a]

SCFactor[a (OverVector[A]).(OverVector[B])+a (OverVector[A]).(OverVector[C]),(OverVector[A])]

SCFactor[a (OverVector[A]).(OverVector[B])+b (OverVector[B]).(OverVector[C]),(OverVector[B])]

SCFactor[A∘B∘C+A∘D∘C,A,C]

SCFactor[B∘D-C∘(D^n),D]

Separation of variables

((\[DifferentialD]y)/(\[DifferentialD]x))==2(E^x)y
SCSepVars[%,x]

Trigonometric Functions

Conversion to other functions

SCTrigConvert[Tan[x],Cos]

SCTrigConvert[Tan[x]+Tanh[x],Cos|Cosh]

Conversion to half angle

SCTrigToHalf[Cos[2x],Sin]

SCTrigToHalf[ArcTan[x]]

Conversion to double angle

SCTrigToDouble[((Cos[x])^2),Cos]

SCTrigToDouble[(1/2)ArcTan[((2x)/(1-(x^2)))]]
SCMAF[%,Simplify,All,ChangeSign->-1+(x^2),PostApply->{PowerExpand,Simplify}]

Complex Variables

Asterisk (*) is interpreted as the complex conjugate

SCComplexExpand[(SuperStar[((E^(u+v)))]),u,TargetFuncs->Conjugate]

The exponential form of a complex number

SCComplexToExp[x+I y]

Rationalization

SCRationalize[(1/(x+I y))]

Contour integration

SCEvalIntResidue[(∫_(-∞)^∞)(1/(1+(x^2)))\[DifferentialD]x,{I,1}]

SCEvalIntResidue[∮((E^(I ω t))/((ω^2)+1))\[DifferentialD]ω,I]

Polynomials and Series

Eliminate the second highest order term

SCMergePoly[(x^3)+a (x^2)+c,x]

Transform a polynomial by making a replacement of the variable

SCTransPoly[(x^3)+a (x^2)+c,x,a+x]

A case of two variables

SCTransPoly[(x^2)(y+a),{x,y},{x-1,y+1},Apply->Simplify]

Taylor expansion

SCTaylorExpand[(Sqrt[1+x]),x,3]

SCTaylorExpand[(Sqrt[1+(((x+Δx))^2)]),Δx,1]

SCAFE[y[x],SCTaylorExpand,{All,x-(Subscript[x, 0]),2,Variables->x},Hold->(Subscript[x, 0]),Head->TildeTilde]

Equations

Adding equations

SCAddEqs[{a==b,c==d,e==f}]

Subtracting equations

SCSubtEqs[{a==b,c==d,e==f}]

Moving a part of an equation to left- or right-hand side

SCEqMove[x+y==z,y,Right]

Eliminating variables from a set of equations

SCEliminate[{x+y==1,x-y+2z==1,y-3z==3},{y,z}]//Simplify

Writing equations in matrix form

SCEqsMatForm[{x+y==1,x-y+2z==1,y-3z==3},{x,y,z}]

SCEqsMatForm[{(Subscript[z, 1])==a x+b y+e,(Subscript[z, 2])==c x+d y+f},{x,y}]

SCEqsMatForm[(Subscript[ξ, 1]^2)+((5 (Subscript[ξ, 2]^2))/8)-((3 (Subscript[ξ, 2]) (Subscript[ξ, 3]))/4)+((5 (Subscript[ξ, 3]^2))/8)==0,{(Subscript[ξ, 1]),(Subscript[ξ, 2]),(Subscript[ξ, 3])},Factor->Automatic]

Differential Calculus

Merging multiple derivative terms

SCMergeDerivs[(∂/(∂y))(a ((∂f)/(∂y)))+(((∂^2)g)/(∂x∂y))]

SCMergeDerivs[(OverDot[(a (OverDot[f]))])+(OverDot[(b ((OverDot[g])^2))]),OverDot->t]

Expansion of derivatives

SCDerivExpand[(∂/(∂x))(((f+Sin[g])/h)),{f,g,h}]

SCDerivExpand[(OverDot[F]),{F==(E^(-I ω t)) f g,f,g},OverDot->t,Apply->Factor]

SCDerivExpand[(\[DifferentialD]/(\[DifferentialD]t))((∂L)/(∂(OverDot[q])))-((∂L)/(∂q))==0,L]

SCDerivExpand[(\[DifferentialD]/(\[DifferentialD]s))((∂ψ)/(∂x)),ψ==ψ[x,t]]

SCDerivExpand[(\[DifferentialD]/(\[DifferentialD]s))((∂ψ)/(∂x)),{ψ==ψ[x,t],x==Cos[s],t==Sin[s]}]

Simplification of derivatives by combining multiple derivative terms

SCDerivSimp[((\[DifferentialD]f)/(\[DifferentialD]x))g+f((\[DifferentialD]g)/(\[DifferentialD]x))]

SCDerivSimp[(((∂^2)Φ)/(∂(r^2)))+(2/r)((∂Φ)/(∂r))]

SCDerivExpand[(\[DifferentialD]/(\[DifferentialD]x))(x (y^2) (\[DifferentialD]/(\[DifferentialD]x))(x ((\[DifferentialD]y)/(\[DifferentialD]x)))),y,Apply->Expand]
SCDerivSimp[%]

SCDerivSimp[(2(y^2)+4(x^2)y)\[DifferentialD]x+(4x y+3(x^3))\[DifferentialD]y]

Transformation of differential operators

SCTransDeriv[(((∂^2)f)/(∂(x^2))),TransVar->{{x,t},{ξ,η}},Apply->Expand]

SCTransDeriv[(((∂^2)f)/(∂(x^2)))-(((∂^2)f)/(∂(y^2))),TransVar->{{x,y},{ξ,η},{ξ==((x+y)/2),η==((x-y)/2)}},Apply->Simplify]

SCTransDeriv[(((∂^2)f)/(∂(x^2)))-(1/(v^2))(((∂^2)f)/(∂(t^2))),TransVar->{{x,t},{ξ,η},{ξ==x-v t,η==x+v t}},Apply->Expand]

Solution of differential equations

(((\[DifferentialD]^2)y)/(\[DifferentialD](x^2)))+y==Cos[x]
SCDSolve[%,y[x],x,Apply->{Simplify,Expand},ReplConst->{A,B}]

((\[DifferentialD]y)/(\[DifferentialD]x))-((y Cos[(y/x)]+y ((Sec[(y/x)])^2)-2 x Sin[(y/x)]-2 x Tan[(y/x)])/(x (Cos[(y/x)]+((Sec[(y/x)])^2))))==0
SCMAF[%,SCDerivSimp,At[1]]

Integration

If integrable, the Integrate function evaluates immediately.

Integrate[x,x]

With the Symbolic Computing package loaded, integrals do not evaluate immediately and can be manipuated algebraically. Use SCEvalInt to evaluate the integral.

SCMergeInts[∫(x-1)\[DifferentialD]x+∫(x+1)\[DifferentialD]x]
SCEvalInt[%]

Combining multiple integrals

(∫f[x]\[DifferentialD]x)(∫g[x]\[DifferentialD]x)
SCCombInts[%,ReplVar->{x,x'}]

Convolution in Fourier transform

The Fourier transform pairs

{f[x]==∫F[k](E^(I k x))\[DifferentialD]k,F[k]==(1/(2π))∫f[x] (E^(-I k x))\[DifferentialD]x}

The inverse Fourier transform of F(k)G(k)

SCARA[∫F[k]G[k](E^(I k x))\[DifferentialD]k,{F[k]==(1/(2π))∫f[x](E^(-I k x))\[DifferentialD]x,G[k]==(1/(2π))∫g[x](E^(-I k x))\[DifferentialD]x}]
SCMAF[%,SCCombInts,{At[2],ReplVar->{x,x',x''}},,
SCFourierToDiracDelta,{At[2],k},
SCEvalIntDelta,{At[2],x''}]

Transformation of the integration variables

SCTransInt[∫f\[DifferentialD]x ,TransVar->{x,y,y==(x^2)}]

SCAFE[(∫_(-∞)^∞)(1/((x^2)+(a^2)))\[DifferentialD]x,SCEvalInt,{All,GenConds->False},Apply->PowerExpand]

SCAFE[(∫_(-∞)^∞)(1/((x^2)+(a^2)))\[DifferentialD]x,SCTransInt,{All,TransVar->{x,θ,x==a Tan[θ]}},
PostApply->{SCEvalInt,PowerExpand}]

SCAFE[∫∫∫f\[DifferentialD]x\[DifferentialD]y\[DifferentialD]z,SCTransInt,{All,TransVar->{{x,y,z},{r,θ,ϕ},{x==r Sin[θ]Cos[ϕ],y==r Sin[θ]Sin[ϕ],z==r Cos[θ]}}},Apply->PowerExpand]

Replacement of the integration variable with others

SCTransInt[∫f\[DifferentialD](x^3) ,Weight->(r^2)Sin[θ],ReplVar->{(x^3),{r,0,∞},{θ,0,π},{ϕ,0,2π}}]

Merging multiple integrals

SCMergeInts[a∫f\[DifferentialD]x+b ∫g\[DifferentialD]x+c∫∫h\[DifferentialD]x\[DifferentialD]y]

Merging integration intervals

SCIntMergeIntervals[(∫_0^a)f[t]\[DifferentialD]t+(∫_a^b)f[t]\[DifferentialD]t]

Integration by parts

SCIntByParts[(∫_(-∞)^x)ψ'[y](y^2)\[DifferentialD]y,ψ'[y]]

SCIntByPartsDeriv[(∫_a^b)(OverDot[ψ])ϕ\[DifferentialD]y,Functions->ϕ]

Summation

If summable, the Sum function evaluates immediately.

Sum[n,n]

With the Symbolic Computing package loaded, sums do not evaluate immediately and can be manipuated algebraically. Use SCEvalSum to evaluate the sum.

SCMergeSums[(∑_n)(n+1)+(∑_n)(n-1)]
SCEvalSum[%]

Changing the summation intervals

SCSumChangeInterval[(∑_(n=-∞)^∞)(Subscript[a, n]),{n,{1,2},{(Subscript[n, 3]),(Subscript[n, 4])}}]

(∑_(n=0)^∞)(((-1))^n)(Subscript[a, n])
SCSumChangeInterval[%,{n,{0,∞,n==2n},{0,∞,n==2n+1}}]

(∑_(n=-∞)^∞)(∑_(m=-∞)^∞)(Subscript[a, n,m])
SCSumChangeInterval[%,{n,{(Subscript[n, 1]),(Subscript[n, 2])},{(Subscript[n, 3]),(Subscript[n, 4])}},{m,{(Subscript[m, 1]),(Subscript[m, 2])},{(Subscript[m, 3]),(Subscript[m, 4])}}]

Combining multiple summations. The indexes are replaced to avoid duplication.

SCCombSums[(∑_(n=1)^∞)(Subscript[f, n])(∑_(n=1)^∞)(Subscript[g, n]),ReplVar->{n,m}]

Merging multiple summations

SCMergeSums[(∑_(k=0)^∞)A[k]+(∑_(k=0)^∞)B[k]]

SCMergeSums[a (∑_(k=0)^∞)A[k]+b(∑_(k=0)^∞)B[k]+(∑_(k=0)^∞)(∑_(m=0)^∞)C[k,m]]

Merging summation intervals

SCSumMergeIntervals[(∑_(n=0)^(k-1))(Subscript[a, n])+(∑_(n=k)^m)(Subscript[a, n])]

Separating multiple sums

(∑_(n=1)^∞)(∑_(m=1)^∞)(Subscript[a, n]) (Subscript[b, m]) (Subscript[f, n])[x] (Subscript[g, n,m])[y]
SCSepSums[%,Order->{m,n}]

(∑_(n=1)^∞)(∑_(m=1)^∞)(∑_(l=1)^∞)(Subscript[a, n]) (Subscript[b, m]) (Subscript[c, l]) (Subscript[f, n])[x] (Subscript[g, n,m])[y]
SCSepSums[%,Group->{n,m}]

Functional Analysis

Variable transformation

y'[x]+y[x]
SCTransFunc[%,y[x]==g[s],TransVar->{x,s,x==(s^2),s==(Sqrt[x])}]

A case of two variables

(∂_(x,x))f[x,y]-(∂_(y,y))f[x,y]
SCTransFunc[%,f[x,y]==g[ξ,η],TransVar->{{x,y},{ξ,η},{ξ==((x+y)/2),η==((x-y)/2)}},Apply->Simplify]

Abbreviation of derivatives

SCAbbrevFunc[I Derivative[0,1][p][x,t]-2 α Derivative[1,0][p][x,t] Derivative[1,0][q][x,t],Derivative->True]

The subscripts denote the derivatives. The function arguments can be restored using SCRestoreFunc.

SCRestoreFunc[I (Subscript[p, t])-2 α (Subscript[p, x]) (Subscript[q, x]),{p,q},Derivative->True]

Taking a factor out of a function

SCFactorFunc[f[a x]+∇\[Cross](a A),CurlHold,a]

Putting a factor inside a function

SCInFunc[f[a x]+a ∇\[Cross]A,CurlHold,a]

Merging arguments of a linear function

SCMergeFuncs[a f[x,z]+b f[y,z],f]

Operator Analysis and Brakets

Expansion of operator expressions

SCBraketExpand[(⟨a|+⟨b|)∘A∘(|α⟩+|β⟩),A]

SCCommutator[(Q/((Subscript[λ, 0])(Sqrt[2])))+I((Subscript[λ, 0])/(ℏ(Sqrt[2])))P,(Q/((Subscript[λ, 0])(Sqrt[2])))-I((Subscript[λ, 0])/(ℏ(Sqrt[2])))P]
SCOpExpand[%,{Q,P}]

Simplify a commutator using a commutation rule [Q,P]≡QP-PQ=i ℏ

SCCommutator[(Q^2),(P^2)]
SCOpSimp[%,{Q,P,I ℏ}]

(Subscript[Q, x])'==(E^(-I ϵ ((Subscript[P, x])/ℏ)))∘(Subscript[Q, x])∘(E^(I ϵ ((Subscript[P, x])/ℏ)))
SCMAF[%,SCTaylorExpand,{At[2],ϵ,5},Level->1,
SCOpSimp,{At[2],{(Subscript[Q, x]),(Subscript[P, x]),I ℏ}},Apply->(Collect[#,ϵ]&),
RA,{All,(ϵ^(n_))/;n>5->0}]

In an orthogonal basis, the density matrix is given by the expression

ρ==(∑_(i=1)^3)(Subscript[p, i])|i⟩∘⟨i|

We now define the states

{|(Subscript[Ψ, 1])⟩==(1/((Subscript[N, 1])(Sqrt[2])))(Sin[θ](Sqrt[(Subscript[p, 1])])|1⟩+Sin[θ](Sqrt[(Subscript[p, 2])])|2⟩+Cos[θ](Sqrt[(Subscript[p, 3])])|3⟩),
|(Subscript[Ψ, 2])⟩==(1/((Subscript[N, 2])(Sqrt[2])))(Cos[θ](Sqrt[(Subscript[p, 1])])|1⟩-Cos[θ](Sqrt[(Subscript[p, 2])])|2⟩+Sin[θ](Sqrt[(Subscript[p, 3])])|3⟩),
|(Subscript[Ψ, 3])⟩==(1/((Subscript[N, 3])(Sqrt[2])))(Sin[θ](Sqrt[(Subscript[p, 1])])|1⟩-Sin[θ](Sqrt[(Subscript[p, 2])])|2⟩-Cos[θ](Sqrt[(Subscript[p, 3])])|3⟩),
|(Subscript[Ψ, 4])⟩==(1/((Subscript[N, 4])(Sqrt[2])))(Cos[θ](Sqrt[(Subscript[p, 1])])|1⟩+Cos[θ](Sqrt[(Subscript[p, 2])])|2⟩-Sin[θ](Sqrt[(Subscript[p, 3])])|3⟩)}

Evaluating the density matrix

ρ==(∑_(k=1)^4)(Subscript[N, k]^2)|(Subscript[Ψ, k])⟩∘⟨(Subscript[Ψ, k])|

we find that it equals the original density matrix

ρ==(∑_(k=1)^4)(Subscript[N, k]^2)|(Subscript[Ψ, k])⟩∘⟨(Subscript[Ψ, k])|
SCMAF[%,SCEvalSum,At[2],,
RA,{At[2],{|(Subscript[Ψ, 1])⟩==(1/((Subscript[N, 1])(Sqrt[2])))(Sin[θ](Sqrt[(Subscript[p, 1])])|1⟩+Sin[θ](Sqrt[(Subscript[p, 2])])|2⟩+Cos[θ](Sqrt[(Subscript[p, 3])])|3⟩),
|(Subscript[Ψ, 2])⟩==(1/((Subscript[N, 2])(Sqrt[2])))(Cos[θ](Sqrt[(Subscript[p, 1])])|1⟩-Cos[θ](Sqrt[(Subscript[p, 2])])|2⟩+Sin[θ](Sqrt[(Subscript[p, 3])])|3⟩),
|(Subscript[Ψ, 3])⟩==(1/((Subscript[N, 3])(Sqrt[2])))(Sin[θ](Sqrt[(Subscript[p, 1])])|1⟩-Sin[θ](Sqrt[(Subscript[p, 2])])|2⟩-Cos[θ](Sqrt[(Subscript[p, 3])])|3⟩),
|(Subscript[Ψ, 4])⟩==(1/((Subscript[N, 4])(Sqrt[2])))(Cos[θ](Sqrt[(Subscript[p, 1])])|1⟩+Cos[θ](Sqrt[(Subscript[p, 2])])|2⟩-Sin[θ](Sqrt[(Subscript[p, 3])])|3⟩)}},
SCBraketExpand,At[2],Apply->Simplify,
RA,{At[2],(Subscript[p, 1]) |1⟩∘⟨1|+(Subscript[p, 2]) |2⟩∘⟨2|+(Subscript[p, 3]) |3⟩∘⟨3|==(∑_(i=1)^3)(Subscript[p, i])|i⟩∘⟨i|}]

The probability that the final state Ψ has the up (↑) state for both a and b is

P[(Subscript["↑", a]),(Subscript["↑", b])]==((\[LeftBracketingBar](⟨(Subscript["↑", a])(Subscript[|, 1])⟨(Subscript["↑", b])(Subscript[|, 2]))∘(Subscript[|Ψ⟩, 1,2])\[RightBracketingBar])^2)
SCMAF[%,RA,{At[2],{(Subscript[|(Subscript["↑", a])⟩, 1])==Cos[(α/2)](Subscript[|"↑"⟩, 1])+Sin[(α/2)](Subscript[|"↓"⟩, 1]),(Subscript[|(Subscript["↑", b])⟩, 2])==Cos[((α+ϕ)/2)](Subscript[|"↑"⟩, 2])+Sin[((α+ϕ)/2)](Subscript[|"↓"⟩, 2]),(Subscript[|Ψ⟩, 1,2])==(1/(Sqrt[2]))((Subscript[|"↑"⟩, 1])(Subscript[|"↓"⟩, 2])-(Subscript[|"↓"⟩, 1])(Subscript[|"↑"⟩, 2]))}},
SCBraketExpand,At[2],
RA,{At[2],{(Subscript[⟨a_|a_⟩, j_])==1,(Subscript[⟨a_|b_⟩, j_])==0}},Apply->Simplify,RemAbs->True]

Vector Calculus

Merging multiple vector operator terms

SCMergeVecOps[a ∇f+b ∇g]

SCMergeVecOps[-∇·(v ∇u)+∇·(u ∇v)]

Evaluation of vector operators

SCEvalVecOp[∇((x^2)y z),Cartesian[x,y,z],{(OverHat[x]),(OverHat[y]),(OverHat[z])}]

SCEvalVecOp[∇\[Cross](OverVector[A]),(OverVector[A])==(OverHat[r])(r^2)Sin[θ]+(OverHat[θ])(r^2) Cos[θ],Spherical[r,θ,ϕ],{(OverHat[r]),(OverHat[θ]),(OverHat[ϕ])}]

SCEvalVecOp[(Subscript[∇, t])·(OverVector[A]),(OverVector[A])==(OverHat[ϕ])(ρ^2)Sin[ϕ](E^(-I k z)),Cylindrical[ρ,ϕ,z],{(OverHat[ρ]),(OverHat[ϕ]),(OverHat[z])},Apply->Simplify]

SCAFE[(∇^2)(OverVector[V]),SCEvalVecOp,{All,(OverVector[V])==(Subscript[V, ρ])[ρ,ϕ,z](OverHat[ρ])+(Subscript[V, ϕ])[ρ,ϕ,z](OverHat[ϕ])+(Subscript[V, z])[ρ,ϕ,z](OverHat[z]),Cylindrical[ρ,ϕ,z],{(OverHat[ρ]),(OverHat[ϕ]),(OverHat[z])},AbbrevFunc->True,Apply->{Simplify,Expand}}]
SCMAF[%,SCDerivSimp,{(1/ρ) ((∂f_)/(∂ρ))+(((∂^2)f_)/(∂(ρ^2)))},Hold->(Subscript[V, a_]),
RA,{At[2],(1/ρ) (∂/(∂ρ))(ρ ((∂f_)/(∂ρ)))+(((∂^2)f_)/(∂(z^2)))+(1/(ρ^2)) (((∂^2)f_)/(∂(ϕ^2)))==(∇^2)f},
Expand,At[2],
SCFactor,{At[2,-4;;-1],(1/(ρ^2))}]

Expansion of vector products and vector operators

SCVecExpand[((OverVector[n])\[Cross]((OverVector[n])\[Cross](OverVector[p])))\[Cross]((OverVector[n])\[Cross]((OverVector[n])\[Cross]((OverVector[n])\[Cross](OverVector[p]))))]

SCVecExpand[∇·(ϵ(OverVector[Ε])[(OverVector[r]),t]),ϵ,Coordinate->(OverVector[r])]

SCVecExpand[∇((OverVector[A]).((OverVector[a])\[Cross](OverVector[B]))),{(OverVector[A]),(OverVector[B])}]

SCVecExpand[(Subscript[(OverVector[v]), A])\[Cross](∇\[Cross](∇\[Cross](((Subscript[(OverVector[v]), 1])(E^(I(OverVector[k]).(OverVector[x]))))\[Cross](Subscript[(OverVector[v]), A]))))-(s^2) ∇(∇·((Subscript[(OverVector[v]), 1])(E^(I(OverVector[k]).(OverVector[x])))))-(ω^2)(Subscript[(OverVector[v]), 1])(E^(I(OverVector[k]).(OverVector[x]))),Coordinate->(OverVector[x])]
SCFactor[%,(E^(I (OverVector[k]).(OverVector[x])))]

Transformation of vector operators

SCTransVecOp[∇f,Coordinate->(OverVector[x]),TransVar->{(OverVector[x]),(OverVector[ρ]),(OverVector[x])==a (OverVector[ρ])}]

SCTransVecOp[(Subscript[∇, (OverVector[x])]^2)f,TransVar->{(OverVector[x]),(OverVector[ρ]),(OverVector[x])==a (OverVector[ρ])}]

SCTransVecOp[-I ℏ (Subscript[∇, (Subscript[(OverVector[x]), 1])])ψ-I ℏ (Subscript[∇, (Subscript[(OverVector[x]), 2])])ψ,TransVar->{{(Subscript[(OverVector[x]), 1]),(Subscript[(OverVector[x]), 2])},{(OverVector[X]),(OverVector[x])},{(OverVector[X])==(((Subscript[m, 1])(Subscript[(OverVector[x]), 1])+(Subscript[m, 2])(Subscript[(OverVector[x]), 2]))/((Subscript[m, 1])+(Subscript[m, 2]))),(OverVector[x])==(Subscript[(OverVector[x]), 1])-(Subscript[(OverVector[x]), 2])}},Apply->Simplify]

Example 1

Series Solution of the Bessel Equation

• Bessel's differential equation

(x^2)(((\[DifferentialD]^2)(Subscript[Z, ν]))/(\[DifferentialD](x^2)))+x((\[DifferentialD](Subscript[Z, ν]))/(\[DifferentialD]x))+((x^2)-(ν^2))(Subscript[Z, ν])==0

Assume the series form of the solution.

(Subscript[Z, ν])==(x^α)(∑_(k=0)^∞)(Subscript[a, k])(x^k)
SCMAF[%,SCInSum,At[2]]

Substitution into the differential equation gives

(x^2)(((\[DifferentialD]^2)(Subscript[Z, ν]))/(\[DifferentialD](x^2)))+x((\[DifferentialD](Subscript[Z, ν]))/(\[DifferentialD]x))+((x^2)-(ν^2))(Subscript[Z, ν])==0
SCMAF[%,RA,{At[1],(Subscript[Z, ν])==(∑_(k=0)^∞)(x^(k+α)) (Subscript[a, k])},Apply->{SCEvalDeriv,SCInSum},
ExpandAll,At[1],Hold->k+_,Apply->SCExpandSum,
SCSumShiftVar,{At[1,(x^(2+k+α))],{k,-2}},
SCMergeSums,{At[1],Apply->Simplify},
Simplify,(k^2)+2 k α+(α^2),
SCSumChangeLimits,{At[1,(Subscript[a, k])],{k,2,∞}},
SCMergeSums,{At[1],Apply->SCFactor}]

• Since the above equation must hold for arbitrary x, we need

(Subscript[a, -2+k])+((((k+α))^2)-(ν^2)) (Subscript[a, k])==0
SCMAF[%,SCSolve,{All,(Subscript[a, k])},Hold->k+α,ChangeSign->(((k+α))^2)-(ν^2)]

and

{((α^2)-(ν^2)) (Subscript[a, 0])==0,((((1+α))^2)-(ν^2)) (Subscript[a, 1])==0}
SCMAF[%,Factor,All,Level->{2}]

These two cases actually give identical solutions.

• For non-integer ν, The solutions are

{(Subscript[J, ν])[x]==(∑_(s=0)^∞)(((((-1))^s) (2^(-ν-2 s)) (x^(ν+2 s)))/(s! (ν+s)!)),(Subscript[J, -ν])[x]==(∑_(s=0)^∞)(((((-1))^s) (2^(ν-2 s)) (x^(-ν+2 s)))/(s! (-ν+s)!))}

For integer ν = n, the two solutions are not independent. We instead take

{(Subscript[J, n])[x]==(∑_(s=0)^∞)(((((-1))^s) (2^(-n-2 s)) (x^(n+2 s)))/(s! (n+s)!)),(Subscript[Y, n])[x]==(lim_(ν->n))(((Subscript[J, ν])[x]Cos[ν π]-(Subscript[J, -ν])[x])/(Sin[ν π]))}

Example 2

Double Pendulum

• The position vectors are

{(Subscript[(OverVector[r]), 1])==(Subscript[l, 1])(Sin[(Subscript[θ, 1])](OverHat[x])-Cos[(Subscript[θ, 1])](OverHat[y])),(Subscript[(OverVector[r]), 2])==(Subscript[(OverVector[r]), 1])+(Subscript[l, 2])(Sin[(Subscript[θ, 2])](OverHat[x])-Cos[(Subscript[θ, 2])](OverHat[y]))}
SCMAF[%,SCEliminate,{All,(Subscript[(OverVector[r]), 1]),1,Keep->True},
Collect,{All,{(OverHat[x]),(OverHat[y])}},Level->{2}]

and the velocity vectors are

SCAFE[{(Subscript[(OverDot[(OverVector[r])]), 1]),(Subscript[(OverDot[(OverVector[r])]), 2])},SCDerivExpand,{All,{(Subscript[(OverVector[r]), 1])==-Cos[(Subscript[θ, 1])] (OverHat[y]) (Subscript[l, 1])+(OverHat[x]) Sin[(Subscript[θ, 1])] (Subscript[l, 1]),(Subscript[(OverVector[r]), 2])==(OverHat[y]) (-Cos[(Subscript[θ, 1])] (Subscript[l, 1])-Cos[(Subscript[θ, 2])] (Subscript[l, 2]))+(OverHat[x]) (Sin[(Subscript[θ, 1])] (Subscript[l, 1])+Sin[(Subscript[θ, 2])] (Subscript[l, 2])),(Subscript[θ, 1]),(Subscript[θ, 2])}}]//Thread

The kinetic energy T is

T==(1/2)(Subscript[m, 1])(Subscript[(OverDot[(OverVector[r])]), 1]).(Subscript[(OverDot[(OverVector[r])]), 1])+(1/2)(Subscript[m, 2])(Subscript[(OverDot[(OverVector[r])]), 2]).(Subscript[(OverDot[(OverVector[r])]), 2])
SCMAF[%,RA,{At[2],{(Subscript[(OverDot[(OverVector[r])]), 1])==Cos[(Subscript[θ, 1])] (OverHat[x]) (Subscript[l, 1]) (Subscript[(OverDot[θ]), 1])+(OverHat[y]) Sin[(Subscript[θ, 1])] (Subscript[l, 1]) (Subscript[(OverDot[θ]), 1]),(Subscript[(OverDot[(OverVector[r])]), 2])==(OverHat[x]) (Cos[(Subscript[θ, 1])] (Subscript[l, 1]) (Subscript[(OverDot[θ]), 1])+Cos[(Subscript[θ, 2])] (Subscript[l, 2]) (Subscript[(OverDot[θ]), 2]))+(OverHat[y]) (Sin[(Subscript[θ, 1])] (Subscript[l, 1]) (Subscript[(OverDot[θ]), 1])+Sin[(Subscript[θ, 2])] (Subscript[l, 2]) (Subscript[(OverDot[θ]), 2]))}},
SCUnitVecExpand,{At[2],{(OverHat[x]),(OverHat[y])}},Apply->{Simplify,Expand},
SCFactor,{(1/2) (Subscript[l, 1]^2) (Subscript[m, 2]) (Subscript[(OverDot[θ]), 1]^2)+(1/2) (Subscript[l, 2]^2) (Subscript[m, 2]) (Subscript[(OverDot[θ]), 2]^2),(1/2)(Subscript[m, 2])}]

and the potential energy V is

V==-(Subscript[m, 1])g (Subscript[l, 1])Cos[(Subscript[θ, 1])]-(Subscript[m, 2])g((Subscript[l, 1])Cos[(Subscript[θ, 1])]+(Subscript[l, 2])Cos[(Subscript[θ, 2])])

The Lagrangian L=T-V is then

L==T-V
SCMAF[%,RA,{At[2],{T==(1/2) (Subscript[l, 1]^2) (Subscript[m, 1]) (Subscript[(OverDot[θ]), 1]^2)+Cos[(Subscript[θ, 1])-(Subscript[θ, 2])] (Subscript[l, 1]) (Subscript[l, 2]) (Subscript[m, 2]) (Subscript[(OverDot[θ]), 1]) (Subscript[(OverDot[θ]), 2])+(1/2) (Subscript[m, 2]) ((Subscript[l, 1]^2) (Subscript[(OverDot[θ]), 1]^2)+(Subscript[l, 2]^2) (Subscript[(OverDot[θ]), 2]^2)),V==-(Subscript[m, 1])g (Subscript[l, 1])Cos[(Subscript[θ, 1])]-(Subscript[m, 2])g((Subscript[l, 1])Cos[(Subscript[θ, 1])]+(Subscript[l, 2])Cos[(Subscript[θ, 2])])}}]

• The Lagrange’s equations of motion with the assumption of small displacements ((Subscript[θ, 1]),(Subscript[θ, 2])≪1) and (Subscript[l, 1])=(Subscript[l, 2])=l for simplicity,

{(\[DifferentialD]/(\[DifferentialD]t))((∂L)/(∂(Subscript[(OverDot[θ]), 1])))-((∂L)/(∂(Subscript[θ, 1])))==0,(\[DifferentialD]/(\[DifferentialD]t))((∂L)/(∂(Subscript[(OverDot[θ]), 2])))-((∂L)/(∂(Subscript[θ, 2])))==0}
SCMAF[%,RR,{All,{L==g Cos[(Subscript[θ, 1])] (Subscript[l, 1]) (Subscript[m, 1])+g (Cos[(Subscript[θ, 1])] (Subscript[l, 1])+Cos[(Subscript[θ, 2])] (Subscript[l, 2])) (Subscript[m, 2])+(1/2) (Subscript[l, 1]^2) (Subscript[m, 1]) (Subscript[(OverDot[θ]), 1]^2)+Cos[(Subscript[θ, 1])-(Subscript[θ, 2])] (Subscript[l, 1]) (Subscript[l, 2]) (Subscript[m, 2]) (Subscript[(OverDot[θ]), 1]) (Subscript[(OverDot[θ]), 2])+(1/2) (Subscript[m, 2]) ((Subscript[l, 1]^2) (Subscript[(OverDot[θ]), 1]^2)+(Subscript[l, 2]^2) (Subscript[(OverDot[θ]), 2]^2)),(Subscript[l, j_])==l}},
SCDerivExpand,All,
SCSolve,{All,{(Subscript[(Overscript[θ, ¨]), 1]),(Subscript[(Overscript[θ, ¨]), 2])},Apply->Simplify},
SCTaylorExpand,{All,{(Subscript[θ, 1]),(Subscript[θ, 2]),(Subscript[(OverDot[θ]), 1]),(Subscript[(OverDot[θ]), 2])}},
Collect,{All,{(Subscript[θ, 1]),(Subscript[θ, 2])},Simplify},Level->{2},
SCFactor,{(Subscript[m, 1])+(Subscript[m, 2]),(Subscript[m, 1])},
SCEqsMatForm,{All,{(Subscript[θ, 1]),(Subscript[θ, 2])},Factor->-(g/l)}]

• The eigenfrequencies are

(ω^2)==Eigenvalues[(g/l) (({{1+((Subscript[m, 2])/(Subscript[m, 1])), -((Subscript[m, 2])/(Subscript[m, 1]))}, {-1-((Subscript[m, 2])/(Subscript[m, 1])), 1+((Subscript[m, 2])/(Subscript[m, 1]))}}))]
SCMAF[%,Simplify,At[2],PowerExpMergeAll->True,PostApply->Expand,
SCFactor,{{(Subscript[m, 1])+(Subscript[m, 2]),(Subscript[m, 1])},PowerExpMergeAll->True,{At[2],(g/l)},Level->1}]

For the mass ratio ((Subscript[m, 2])/(Subscript[m, 1]))=(1/3), the eigenfrequencies are

(ω^2)=={(g/l) (1+((Subscript[m, 2])/(Subscript[m, 1]))-(Sqrt[((Subscript[m, 2])/(Subscript[m, 1])) (1+((Subscript[m, 2])/(Subscript[m, 1])))])),(g/l) (1+((Subscript[m, 2])/(Subscript[m, 1]))+(Sqrt[((Subscript[m, 2])/(Subscript[m, 1])) (1+((Subscript[m, 2])/(Subscript[m, 1])))]))}
SCMAF[%,RR,{At[2],((Subscript[m, 2])/(Subscript[m, 1]))==(1/3)},Apply->Simplify]

and the solutions for (Subscript[θ, 1]) and (Subscript[θ, 2]) with the initial conditions (Subscript[θ, 1])'(0)=0,(Subscript[θ, 2])'(0)=0,(Subscript[θ, 1])(0)=(Subscript[θ, 0]),(Subscript[θ, 2])(0)=0

{(Subscript[(Overscript[θ, ¨]), 1])==-((g (Subscript[θ, 1]))/l) (1+((Subscript[m, 2])/(Subscript[m, 1])))+((g (Subscript[m, 2]) (Subscript[θ, 2]))/(l (Subscript[m, 1]))),(Subscript[(Overscript[θ, ¨]), 2])==((g (Subscript[θ, 1]))/l) (1+((Subscript[m, 2])/(Subscript[m, 1])))-((g (Subscript[θ, 2]))/l) (1+((Subscript[m, 2])/(Subscript[m, 1])))}
SCMAF[%,RA,{All,((Subscript[m, 2])/(Subscript[m, 1]))==(1/3)},
SCDSolve,{All,{(Subscript[θ, 1])'[0]==0,(Subscript[θ, 2])'[0]==0,(Subscript[θ, 1])[0]==(Subscript[θ, 0]),(Subscript[θ, 2])[0]==0},{(Subscript[θ, 1])[t],(Subscript[θ, 2])[t]},t},PowerMerge->True]

• Motion of the double pendulum with (Subscript[θ, 0])=(1/5)

{(Subscript[(OverVector[r]), 1])==-Cos[(Subscript[θ, 1])] (OverHat[y]) (Subscript[l, 1])+(OverHat[x]) Sin[(Subscript[θ, 1])] (Subscript[l, 1]),(Subscript[(OverVector[r]), 2])==-(OverHat[y]) (Cos[(Subscript[θ, 1])] (Subscript[l, 1])+Cos[(Subscript[θ, 2])] (Subscript[l, 2]))+(OverHat[x]) (Sin[(Subscript[θ, 1])] (Subscript[l, 1])+Sin[(Subscript[θ, 2])] (Subscript[l, 2]))}
SCMAF[%,RA,{All,(Subscript[l, j_])==(1/2)},
Simplify,All,Level->{2},
SCEqsGroupSides,All,
SCUnitVecToVec,{At[2],{(OverHat[x]),(OverHat[y])}},
RA,{At[2],{(Subscript[θ, 1])[t]==((Subscript[θ, 0])/2) (Cos[(Sqrt[(2/3)])(Sqrt[(g/l)]) t]+Cos[(Sqrt[2])(Sqrt[(g/l)]) t]),(Subscript[θ, 2])[t]==(Subscript[θ, 0]) (Cos[(Sqrt[(2/3)])(Sqrt[(g/l)]) t]-Cos[(Sqrt[2])(Sqrt[(g/l)]) t])}},RA->{(g/l)==1,(Subscript[θ, 0])==(1/5)},
SCListPlot,{At[2],AxesLabel->{x,y}, PlotRange->{{-0.6,0.6},{-1.1,0.1}},PlotStyle->PointSize[0.05],AspectRatio->1,Epilog->{Line[{{0,0},SCMAFOutput[[2,1]],SCMAFOutput[[2,2]]}]}},HoldForm->True,,,
Manipulate,{At[2],{t,0,100}},Take->Last]

Example 3

Center-Fed Linear Antenna

Ref.: J. Jackson, "Classical Electrodynamics," Chapter 9

• If A is the vector potential, the magnetic field in the radiation zone for the center-fed linear antenna is

(OverVector[H])==((I k)/(Subscript[μ, 0]))(OverVector[n])\[Cross](OverVector[A])

with the magnitude

\[LeftDoubleBracketingBar](OverVector[H])\[RightDoubleBracketingBar]==(k/(Subscript[μ, 0]))\[LeftBracketingBar](Subscript[A, z])\[RightBracketingBar]Sin[θ]

where

(Subscript[A, z])==(((E^(I k r)) Ι ((Csc[θ])^2) (Subscript[μ, 0]))/(2 k π r))(-Cos[((d k)/2)]+Cos[(1/2) d k Cos[θ]])

• Then the time-averaged power radiated per unit solid angle is

((\[DifferentialD]P)/(\[DifferentialD]Ω))==(1/2)(r^2)Re[(OverVector[n]).(OverVector[Ε])\[Cross](SuperStar[(OverVector[H])])]
SCMAF[%,SCVecOrder,{At[2],((OverVector[n])\[Cross](OverVector[Ε]))._},,
RA,{At[2],(OverVector[Ε])==(Subscript[Z, 0]) (OverVector[H])\[Cross](OverVector[n])},Apply->SCVecExpand,RA->{(OverVector[n]).(OverVector[n])==1,(OverVector[n]).(OverVector[H])==0,(OverVector[H]).(SuperStar[(OverVector[H])])==((\[LeftDoubleBracketingBar](OverVector[H])\[RightDoubleBracketingBar])^2)},RemFunc->Re]

This gives the formula for the radiation pattern and a function of the latitude angle θ

((\[DifferentialD]P)/(\[DifferentialD]Ω))==(1/2) (r^2) ((\[LeftDoubleBracketingBar](OverVector[H])\[RightDoubleBracketingBar])^2) (Subscript[Z, 0])
SCMAF[%,RA,{At[2],\[LeftDoubleBracketingBar](OverVector[H])\[RightDoubleBracketingBar]==(k/(Subscript[μ, 0]))\[LeftBracketingBar](Subscript[A, z])\[RightBracketingBar]Sin[θ]},
RA,{At[2],(Subscript[A, z])==(((E^(I k r)) Ι ((Csc[θ])^2) (Subscript[μ, 0]))/(2 k π r))(-Cos[((d k)/2)]+Cos[(1/2) d k Cos[θ]])},RemAbs->True,RA->_Im==0]

• Polar plot of the radiation pattern

((\[DifferentialD]P)/(\[DifferentialD]Ω))==(((Ι^2) ((Csc[θ])^2) (Subscript[Z, 0]))/(8 (π^2)))(((-Cos[((d k)/2)]+Cos[(1/2) d k Cos[θ]]))^2)
SCMAF[%,RA,{At[2],k d==π κ},Comment->"Use κ = \!\(\*FractionBox[\(k\\ d\), \(π\)]\) = ((2  d)/λ).",
SCDivEq,{All,(((Ι^2) (Subscript[Z, 0]))/(8 (π^2)))},
PolarPlot,{At[2],{θ,0,2π},PlotRange->4,AxesLabel->{"x, y",z}},HoldForm->True,,,
Manipulate,{At[2],{{κ,0,"κ=((2  d)/λ)"},0,8}},Take->Last,Off->∞::"indet"]

Example 4

Quantum Mechanical Harmonic Oscillator

Ref.: R. Loudon, "The Quantum Theory of Light," Chapter 4

• The Hamiltonian is

(OverHat[ℋ])==(((OverHat[p])^2)/(2 m))+(1/2) m (ω^2) ((OverHat[q])^2)
SCMAF[%,RA,{At[2],{(OverHat[q])==(1/(Sqrt[2]))(Sqrt[(ℏ/(m ω))]) ((OverHat[a])+(SuperDagger[(OverHat[a])])),(OverHat[p])==((I (Sqrt[m ω ℏ]) (-(OverHat[a])+(SuperDagger[(OverHat[a])])))/(Sqrt[2]))}},
SCOpExpand,At[2],
SCFactor,{At[2],((ω ℏ)/2)}]

With

𝒞[(OverHat[q]),(OverHat[p])]==I ℏ
SCMAF[%,RA,{At[1],{(OverHat[q])==(1/(Sqrt[2]))(Sqrt[(ℏ/(m ω))]) ((OverHat[a])+(SuperDagger[(OverHat[a])])),(OverHat[p])==((I (Sqrt[m ω ℏ]) (-(OverHat[a])+(SuperDagger[(OverHat[a])])))/(Sqrt[2]))}},
SCExpandFunc,{At[1],𝒞,(OverHat[a])},Apply->PowerExpand,
RA,{At[1],𝒞==SCCommutator},Apply->Expand,
SCFactor,{At[1],-I ℏ},RA->-(OverHat[a])∘(SuperDagger[(OverHat[a])])+(SuperDagger[(OverHat[a])])∘(OverHat[a])==𝒞[(SuperDagger[(OverHat[a])]),(OverHat[a])],
SCDivEq,{All,-I ℏ}]

the Hamiltonian can be put in the form

(OverHat[ℋ])==((ω ℏ)/2) ((OverHat[a])∘(SuperDagger[(OverHat[a])])+(SuperDagger[(OverHat[a])])∘(OverHat[a]))
SCMAF[%,SCOpSimp,{At[2],{(SuperDagger[(OverHat[a])]),(OverHat[a]),-1}},
SCFactor,{At[2],ω ℏ}]

• The energy eigenstates |n⟩ satisfy the eigenvalue equation

SCARE[(OverHat[ℋ])∘|n⟩,(OverHat[ℋ])==ω ℏ ((1/2)+(SuperDagger[(OverHat[a])])∘(OverHat[a]))]
SCMAF[%,SCOpExpand,At[2],
SCFactor,{At[2],ω ℏ},
Append,{All,(Subscript[Ε, n])|n⟩}]

where

(SuperDagger[(OverHat[a])])∘(OverHat[a])∘|n⟩==n|n⟩

and

(Subscript[Ε, n])==(n+(1/2))ω ℏ

• Determination of the coefficient (Subscript[C, n]) for the relation

(OverHat[a])∘|n⟩==(Subscript[C, n])|n-1⟩

The Hermitian conjugate of the above relation is

⟨n|∘(SuperDagger[(OverHat[a])])==(SuperStar[(Subscript[C, n])])⟨n-1|

Multiplying the the two equations gives

{(OverHat[a])∘|n⟩==(Subscript[C, n])|n-1⟩,⟨n|∘(SuperDagger[(OverHat[a])])==(SuperStar[(Subscript[C, n])])⟨n-1|}
SCMAF[%,SCMultEqs,{All,{2,1},OPMul,Keep->False},
RA,{All,(SuperDagger[(OverHat[a])])∘(OverHat[a])∘|n⟩==n|n⟩},Apply->SCBraketExpand,RA->⟨n_|n_⟩==1,ToAbs->True]

Taking (Subscript[C, n]) to be real, we have

(Subscript[C, n])==(Sqrt[n])

and therefore,

(OverHat[a])∘|n⟩==(Sqrt[n])|n-1⟩

Similarly, we can derive

(SuperDagger[(OverHat[a])])∘|n⟩==(Sqrt[n+1])|n+1⟩

• Use the above results to evaluate

SCAFE[⟨n|((((SuperDagger[(OverHat[a])])))^3)∘((OverHat[a])^4)∘(SuperDagger[(OverHat[a])])|n⟩,SCBraketExpandAll,{All,Power->False}]
SCMAF[%,RR,{At[2],{(OverHat[a])∘(c_. |n_⟩)==c(Sqrt[n])|n-1⟩,(SuperDagger[(OverHat[a])])∘(c_. |n_⟩)==c(Sqrt[n+1])|n+1⟩}},SCBraketExpand,At[2],Hold->n+_.,RA->⟨n|n⟩==1]

Example 5

Hamiltonian of the Quantized Electromagnetic Field

Ref.: R. Loudon, "The Quantum Theory of Light," Chapter 4

• The electromagnetic radiation Hamiltonian is written in a form analogous to the classical energy as

(Subscript[(OverHat[ℋ]), R])==(1/2)∫((Subscript[ϵ, 0]) (Subscript[(OverHat[(OverVector[Ε])]), T])[(OverVector[r]),t]·(Subscript[(OverHat[(OverVector[Ε])]), T])[(OverVector[r]),t]+(((OverHat[(OverVector[B])])[(OverVector[r]),t]·(OverHat[(OverVector[B])])[(OverVector[r]),t])/(Subscript[μ, 0])))\[DifferentialD]V

The field operators are given by

{(Subscript[(OverHat[(OverVector[Ε])]), T])[(OverVector[r]),t]==(∑_(OverVector[k]))(∑_λ)(Subscript[(OverVector[e]), (OverVector[k]),λ]) (Subscript[(OverHat[Ε]), (OverVector[k]),λ])[(OverVector[r]),t],(OverHat[(OverVector[B])])[(OverVector[r]),t]==(∑_(OverVector[k]))(∑_λ)(((OverVector[k])\[Cross](Subscript[(OverVector[e]), (OverVector[k]),λ]))/(\[LeftDoubleBracketingBar](OverVector[k])\[RightDoubleBracketingBar]))(Subscript[(OverHat[B]), (OverVector[k]),λ])[(OverVector[r]),t]}

where

{(Subscript[(OverHat[Ε]), (OverVector[k]),λ])[(OverVector[r]),t]==(1/(Sqrt[2]))(Sqrt[((ℏ (Subscript[ω, k]))/(V (Subscript[ϵ, 0])))]) ((E^(-I (Subscript[χ, (OverVector[k])])[(OverVector[r]),t])) (Subscript[(OverHat[a]), (OverVector[k]),λ])+(E^(I (Subscript[χ, (OverVector[k])])[(OverVector[r]),t])) (SuperDagger[(Subscript[(OverHat[a]), (OverVector[k]),λ])])),(Subscript[(OverHat[Ε]), (OverVector[k]),λ])[(OverVector[r]),t]==(1/(Sqrt[2]))(Sqrt[((ℏ (Subscript[μ, 0]) (Subscript[ω, k]))/V)]) ((E^(-I (Subscript[χ, (OverVector[k])])[(OverVector[r]),t])) (Subscript[(OverHat[a]), (OverVector[k]),λ])+(E^(I (Subscript[χ, (OverVector[k])])[(OverVector[r]),t])) (SuperDagger[(Subscript[(OverHat[a]), (OverVector[k]),λ])]))}

where (Subscript[(OverVector[e]), (OverVector[k]),λ]) is the unit vector for polarization of the mode with wave vector (OverVector[k]) and wavelength λ, and (Subscript[(OverHat[a]), (OverVector[k]),λ]) and (SuperDagger[(Subscript[(OverHat[a]), (OverVector[k]),λ])]) are the annihilation and creation operators for the mode. Then it can be shown

(Subscript[(OverHat[ℋ]), R])==(∑_(OverVector[k]))(∑_λ)ℏ (Subscript[ω, k]) ((1/2)+(SuperDagger[(Subscript[(OverHat[a]), (OverVector[k]),λ])])∘(Subscript[(OverHat[a]), (OverVector[k]),λ]))

• Evaluating the integrals, we obtain

(Subscript[(OverHat[ℋ]), R])==(1/2)∫((Subscript[ϵ, 0]) (Subscript[(OverHat[(OverVector[Ε])]), T])[(OverVector[r]),t]·(Subscript[(OverHat[(OverVector[Ε])]), T])[(OverVector[r]),t]+(((OverHat[(OverVector[B])])[(OverVector[r]),t]·(OverHat[(OverVector[B])])[(OverVector[r]),t])/(Subscript[μ, 0])))\[DifferentialD]V
SCMAF[%,RA,{At[2],{(Subscript[(OverHat[(OverVector[Ε])]), T])[(OverVector[r]),t]==(∑_(OverVector[k]))(∑_λ)(Subscript[(OverVector[e]), (OverVector[k]),λ]) (Subscript[(OverHat[Ε]), (OverVector[k]),λ])[(OverVector[r]),t],(OverHat[(OverVector[B])])[(OverVector[r]),t]==(∑_(OverVector[k]))(∑_λ)(((OverVector[k])\[Cross](Subscript[(OverVector[e]), (OverVector[k]),λ]))/(\[LeftDoubleBracketingBar](OverVector[k])\[RightDoubleBracketingBar]))(Subscript[(OverHat[B]), (OverVector[k]),λ])[(OverVector[r]),t]}},FormatTimes->False,
SCCombSums,{At[2],ReplVar->{{(OverVector[k]),(OverVector[k])'},{λ,λ'}}},Apply->SCMergeSums,
SCOpExpand,At[2],Apply->SCVecExpand,VecOrder->{(OverVector[k])._,(OverVector[k])'._},
RA,{At[2],{(Subscript[(OverHat[Ε]), K_,λ_])[(OverVector[r]),t]==(1/(Sqrt[2]))(Sqrt[((ℏ (Subscript[ω, \[LeftDoubleBracketingBar]K\[RightDoubleBracketingBar]]))/(V (Subscript[ϵ, 0])))]) ((E^(-I (Subscript[χ, K])[(OverVector[r]),t])) (Subscript[(OverHat[a]), K,λ])+(E^(I (Subscript[χ, K])[(OverVector[r]),t])) (SuperDagger[((Subscript[(OverHat[a]), K,λ]))])),(Subscript[(OverHat[B]), K_,λ_])[(OverVector[r]),t]==(1/(Sqrt[2]))(Sqrt[((ℏ (Subscript[μ, 0]) (Subscript[ω, \[LeftDoubleBracketingBar]K\[RightDoubleBracketingBar]]))/V)]) ((E^(-I (Subscript[χ, K])[(OverVector[r]),t])) (Subscript[(OverHat[a]), K,λ])+(E^(I (Subscript[χ, K])[(OverVector[r]),t])) (SuperDagger[((Subscript[(OverHat[a]), K,λ]))]))}},
RA,{At[2],(Subscript[χ, K_])[(OverVector[r]),t]==(Subscript[ω, \[LeftDoubleBracketingBar]K\[RightDoubleBracketingBar]])t-K.(OverVector[r])-(π/2)},
SCOpExpand,At[2],Apply->{ExpandAll,SCSimpExp,PowerExpand},FactorExp->{I,(OverVector[k]).(OverVector[r])},PowerMerge->True,
SCFactor,a_. (OverVector[k]).(OverVector[r])+b_.(OverVector[k])'.(OverVector[r]),
SCIntInSum,At[2],Apply->SCExpandIntAll,
SCFactorInt,{At[2],Variables->(OverVector[r])},Hold->(1/V),
RA,{At[2],{∫(E^(I K_ .(OverVector[r])))\[DifferentialD]V==V (Subscript[δ, K,0]),∫(E^(-I K_ .(OverVector[r])))\[DifferentialD]V==V (Subscript[δ, K,0])}},
SCEvalSumDelta,{At[2],(OverVector[k])'},Apply->SCVecExpand,
RA,{At[2],{(OverVector[k]).(Subscript[(OverVector[e]), (OverVector[k]),λ])==0,(Subscript[(OverVector[e]), (OverVector[k]),λ]).(Subscript[(OverVector[e]), (OverVector[k]),λ'])==(Subscript[δ, λ,λ']),(OverVector[k]).(OverVector[k])==((\[LeftDoubleBracketingBar](OverVector[k])\[RightDoubleBracketingBar])^2)}},Apply->{SCMergeSums,PowerExpand},
SCEvalSumDelta,{At[2],λ'},Apply->SCMergeSums,
SCFactor,{At[1],(1/2) ℏ (Subscript[ω, \[LeftDoubleBracketingBar](OverVector[k])\[RightDoubleBracketingBar]])},Base->_Sum,
SCOpSimp,{(Subscript[(OverHat[a]), (OverVector[k]),λ])∘(SuperDagger[((Subscript[(OverHat[a]), (OverVector[k]),λ]))])+(SuperDagger[((Subscript[(OverHat[a]), (OverVector[k]),λ]))])∘(Subscript[(OverHat[a]), (OverVector[k]),λ]),{(SuperDagger[((Subscript[(OverHat[a]), (OverVector[k]),λ]))]),(Subscript[(OverHat[a]), (OverVector[k]),λ]),-1}},
SCFactor,{1+2(SuperDagger[((Subscript[(OverHat[a]), (OverVector[k]),λ]))])∘(Subscript[(OverHat[a]), (OverVector[k]),λ]),2},
RA,{At[2],\[LeftDoubleBracketingBar](OverVector[k])\[RightDoubleBracketingBar]==k}]