(*********************************************************************** Mathematica-Compatible Notebook This notebook can be used on any computer system with Mathematica 4.0, MathReader 4.0, or any compatible application. The data for the notebook starts with the line containing stars above. To get the notebook into a Mathematica-compatible application, do one of the following: * Save the data starting with the line of stars above into a file with a name ending in .nb, then open the file inside the application; * Copy the data starting with the line of stars above to the clipboard, then use the Paste menu command inside the application. Data for notebooks contains only printable 7-bit ASCII and can be sent directly in email or through ftp in text mode. Newlines can be CR, LF or CRLF (Unix, Macintosh or MS-DOS style). NOTE: If you modify the data for this notebook not in a Mathematica- compatible application, you must delete the line below containing the word CacheID, otherwise Mathematica-compatible applications may try to use invalid cache data. For more information on notebooks and Mathematica-compatible applications, contact Wolfram Research: web: http://www.wolfram.com email: info@wolfram.com phone: +1-217-398-0700 (U.S.) Notebook reader applications are available free of charge from Wolfram Research. ***********************************************************************) (*CacheID: 232*) (*NotebookFileLineBreakTest NotebookFileLineBreakTest*) (*NotebookOptionsPosition[ 18448, 652]*) (*NotebookOutlinePosition[ 19129, 676]*) (* CellTagsIndexPosition[ 19085, 672]*) (*WindowFrame->Normal*) Notebook[{ Cell[CellGroupData[{ Cell["\<\ Decomposition to products, and Recombination to sums of Spherical Harmonics\ \>", "Subtitle", Evaluatable->False, CellHorizontalScrolling->False, TextAlignment->Center], Cell["01/12/2001 07/12/2009", "Text"], Cell[TextData[{ "with thanks to ", StyleBox["Paul Abbott", FontVariations->{"Underline"->True}], ", who explained the 3J-symbols to me in a 15 line mail (in 2001, at a time \ when Wiki was not yet born)." }], "Text"], Cell["The Spherical Harmonics are symbolised by ylm[l,m] :", "Text"], Cell[CellGroupData[{ Cell["Initialisations", "Subsubsection"], Cell["ylm[0,0]:=1/2/Sqrt[Pi]", "Input", InitializationCell->True], Cell["This defines the coefficient \"co\" :", "Text", Evaluatable->False], Cell["\<\ co[a_,ma_,b_,mb_,c_,mc_]:=Sqrt[(2a+1)(2b+1)(2c+1)\t /4/Pi ]* \t\t\t\t\t\tThreeJSymbol[{a,ma},{b,mb},{c,mc}]* \t\t\t\t\t\tThreeJSymbol[{a,0 },{b,0 },{c,0 }]\ \>", "Input", PageWidth->Infinity, InitializationCell->True], Cell["by Functions (24/11/2009)", "Text"], Cell["\<\ tosum1[form_]:=Collect[Simplify[Expand[form] /. {ylm[a_,ma_]^n_ :> ylm[a,ma]^(n-2) Module[{mc},Sum[co[a,ma,a,ma,c,mc=-ma-ma] \ (-1)^mc ylm[c,-mc],{c,Max[Abs[ma+ma],Abs[a-a]],a+a}] ], ylm[a_,ma_] ylm[b_,mb_]:> Module[{mc},Sum[co[a,ma,b,mb,c,mc=-ma-mb] (-1)^mc \ ylm[c,-mc],{c,Max[Abs[ma+mb],Abs[a-b]],a+b}] ] }],_ylm]\ \>", "Input", InitializationCell->True], Cell["tosum[form_]:=Collect[FixedPoint[tosum1,form],_ylm]", "Input", InitializationCell->True], Cell["\<\ toproduct1[form_]:= Expand[form /. {ylm[l_,m_] :> Sum[ClebschGordan[{a,b},{l-a,m-b},{l,m}] ylm[a,b] \ ylm[l-a,m-b]Sqrt[(2l+1)/3/l \ 4Pi],{a,l-1,l-1},{b,Max[-a,a-l+m],Min[a,l-a+m]}]}]\ \>", "Input", InitializationCell->True], Cell["toproduct[form_]:=Expand[FixedPoint[toproduct1,form]]", "Input", InitializationCell->True] }, Closed]], Cell[CellGroupData[{ Cell[TextData[{ "Group products and powers to monomials in higer orders of ylm : ", StyleBox["tosum[ ]", FontColor->RGBColor[1, 0, 0]], "\nand decompose higher orders into products of order one : \ ", StyleBox["toproduct[ ]", FontColor->RGBColor[1, 0, 0]], " " }], "Subsubsection"], Cell["Let ylm[ ] be undefined for now ...", "Text", Evaluatable->False], Cell["SphericalHarmonicY[0,0,th,fi]", "Input"], Cell["\<\ Polynomial expressions in y[ ] are now expanded to degree-one linear \ combinations of y[_ , _ ] :\ \>", "Text", Evaluatable->False], Cell["ylm[1,0] ylm[2,1] ylm[2,0]//tosum", "Input", PageWidth->Infinity], Cell["ylm[1,1]^4+4 ylm[2,0]^2+3 ylm[1,-1]ylm[3,1]+ylm[4,2] //tosum", "Input", PageWidth->Infinity], Cell["%//toproduct", "Input"], Cell["tosum[%]", "Input"], Cell["\<\ now we can take it apart, and, after simplification, it gets glued back \ together again !\ \>", "Text"], Cell["\<\ ylm[5,-1] %//toproduct\ \>", "Input", PageWidth->Infinity], Cell["%//tosum", "Input"], Cell["\<\ the following matrix has a determinant that simplifies to zero:\ \>", "Text"], Cell["\<\ (mat=Table[ylm[Max[Abs[i],Abs[j]],j]ylm[Max[Abs[j],Abs[i]],i],{j,-1,1},{i,-1,\ 1}])//Simplify \ \>", "Input", PageWidth->Infinity], Cell["Det[mat]//Simplify", "Input", PageWidth->Infinity], Cell["Det[mat-x IdentityMatrix[3]]//Simplify", "Input", PageWidth->Infinity], Cell["%//tosum", "Input"], Cell["%//toproduct", "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Decomposition of Polytopes into Spherical Harmonics", "Subsubsection"], Cell["<True], Cell["<True], Cell["<True], Cell["\<\ myArg[z_]:=If[Chop[z]===0,0.5,Chop[1/2+Arg[z]/2/\[Pi]]]\ \>", "Input", InitializationCell->True], Cell["Vertices[Icosahedron]", "Input"], Cell["icon=CoordinatesFromCartesian[#,Spherical]&/@ %;", "Input"], Cell["package the ylm[l,m] in a square matrix ", "Text"], Cell["n=6;(matbc=Table[ ylm[j~Max~i,j-i,b,c],{i,0,n},{j,0,n}] );", "Input"], Cell["\<\ evaluate this matrix at every point of the indices list, simulating \ Integrate[ ylm[l,m,th,fi] (-1)^m ylm[l,-m,th_of_vertex,fi_of_vertex] d\ \[CapitalOmega] ] = Integrate[ ylm[l,m,th,fi] (-1)^m ylm[l,m,th,fi] d\ \[CapitalOmega] ] \[Delta](th, th_of_vertex) \[Delta](fi, fi_of_vertex) in other words, consider the discontinuous vertex coordinates as a smooth \ function over th and fi multiplied by Kronecker delta's on the vertices.\ \>", "Text"], Cell["intermed1=N[Function[{a,b,c},Evaluate@matbc]@@@icon];", "Input"], Cell["\<\ enter the vertices as the conjugate ylm[ , ] so that the coefficients are for \ the sqare matrix of ylm's as defined above. Without this, we would get the stuff mirrored by fi -> (-fi)\ \>", "Text"], Cell["\<\ intermed2=Chop[N[intermed1 /. ylm[l_,m_,b_,c_] ->(-1)^m \ SphericalHarmonicY[l,-m,b,c] ]] ;\ \>", "Input"], Cell["now, just add the matrices of all points", "Text"], Cell["(intermed3=Chop[Plus@@intermed2])//MatrixForm", "Input"], Cell["exactcoeff=intermed3/. q_?NumericQ/;(!MatchQ[q,0]) ->1", "Input"], Cell["\<\ this shows the resulting decomposition of the Polytope into a linear \ combination of Spherical Harmonics up to the selected degree\ \>", "Text"], Cell["\<\ sym=Plus@@Flatten[matbc intermed3] /. {b->Sequence[],c->Sequence[]}\ \>", "Input"], Cell["delayed reduction into elementary trigonometric functions", "Text"], Cell["fun=%/. ylm[l_,m_] ->SphericalHarmonicY[l,m,th,fi];", "Input"], Cell["\<\ SphericalPlot3D[{Abs[fun],SurfaceColor[ Hue[ myArg[fun]]]},{th,0,Pi},{fi,0, 2 \ Pi},PlotPoints->60,PlotRange->All]\ \>", "Input"] }, Closed]], Cell[CellGroupData[{ Cell[TextData[{ "The bra-ket \[LeftAngleBracket] u , v \[RightAngleBracket] :: type ", StyleBox["Esc < Esc", FontWeight->"Plain"], " and ", StyleBox["Esc > Esc", FontWeight->"Plain"], " :: ", StyleBox["AngleBracket[u, v] ", FontWeight->"Plain"] }], "Subsubsection"], Cell[" \[LeftAngleBracket]u,v\[RightAngleBracket]//FullForm", "Input"], Cell[TextData[{ "the definition as an integral over the sphere: \[LeftAngleBracket] u , v \ \[RightAngleBracket] is \[Integral] u (", Cell[BoxData[ \(\(v\^*\)\)]], ") d\[CapitalOmega] = Integrate[ u[\[Theta],\[Phi]] v[\[Theta], -\[Phi]] \ Sin[\[Theta]] ,{\[Theta],0,\[Pi]}, {\[Phi],0,2\[Pi]}],\nOrthogonality of the \ Spherical Harmonics ylm[l,m] simplifies " }], "Text"], Cell["\<\ \[LeftAngleBracket]ylm[a_,b_],ylm[c_,d_]\[RightAngleBracket]:=1 \ /;And[a==c,b==d]\ \>", "Input", InitializationCell->True], Cell["\<\ \[LeftAngleBracket]ylm[a_,b_],ylm[c_,d_]\[RightAngleBracket]:=0 \ /;Or[a!=c,b!=d]\ \>", "Input", InitializationCell->True], Cell["\<\ \[LeftAngleBracket]c1_?NumericQ,c2_?NumericQ\[RightAngleBracket]:=4 Pi c1 \ c2\ \>", "Input", InitializationCell->True], Cell["\<\ \[LeftAngleBracket]c1_?NumericQ x_ylm+ y_, z_\[RightAngleBracket]:= c1 \ \[LeftAngleBracket]x,z\[RightAngleBracket]+ \[LeftAngleBracket]y,z\ \[RightAngleBracket]; \[LeftAngleBracket]x_, c1_?NumericQ y_ylm+z_\[RightAngleBracket]:= c1 \ \[LeftAngleBracket]x,y\[RightAngleBracket]+\[LeftAngleBracket]x,z\ \[RightAngleBracket]; \[LeftAngleBracket]c_?NumericQ x_ylm,y_\[RightAngleBracket]:= c \ \[LeftAngleBracket]x,y\[RightAngleBracket]; \[LeftAngleBracket]x_, c_?NumericQ y_ylm\[RightAngleBracket]:= c \ \[LeftAngleBracket]x,y\[RightAngleBracket]; \[LeftAngleBracket]x_, c1_?NumericQ +y_\[RightAngleBracket]:= \ \[LeftAngleBracket]x,y\[RightAngleBracket]; \[LeftAngleBracket]c1_?NumericQ + x_, y_\[RightAngleBracket]:= \ \[LeftAngleBracket]x,y\[RightAngleBracket]; \[LeftAngleBracket]c_?NumericQ , y_\[RightAngleBracket]:= 0; \[LeftAngleBracket]x_,c_?NumericQ\[RightAngleBracket]:= 0\ \>", "Input", InitializationCell->True], Cell["\<\ cleanup[expr_]:=FullSimplify[FixedPoint[tosum[ExpandAll[#]]&,expr],\ TransformationFunctions->{Automatic,ExpandAll,tosum,ExpandAll[Apart/@\ ExpandAll[#]]&}]\ \>", "Input", InitializationCell->True], Cell["cl[expr_]:=FixedPoint[Collect[ExpandAll[#],_ylm]&,expr]", "Input", InitializationCell->True], Cell["\<\ Integrate[SphericalHarmonicY[1,0,th,fi]^3 SphericalHarmonicY[3,0,th,-fi] \ Sin[th],{th,0,Pi},{fi,0,2Pi}]\ \>", "Input"], Cell["\[LeftAngleBracket]ylm[1,0]^3,ylm[3,0]\[RightAngleBracket]//cleanup", \ "Input"], Cell["\<\ (mat=Table[ylm[Max[Abs[i],Abs[j]],j]ylm[Max[Abs[j],Abs[i]],i],{j,-1,1},{i,-1,\ 1}])//Simplify\ \>", "Input"], Cell["\<\ mat2=Table[ \ \[LeftAngleBracket]mat[[i,j]],mat[[4-i,4-j]]\[RightAngleBracket],{i,3},{j,3}]\ \ \>", "Input"], Cell["mat2 //cleanup", "Input"], Cell["Det[mat2//cleanup]", "Input"], Cell["ylm[4,-2]ylm[2,-1]//tosum", "Input"], Cell["\<\ Table[\[LeftAngleBracket]ylm[4,-2]ylm[3,-1],ylm[l,-2-1]\[RightAngleBracket],{\ l,4-3,4+3}]//cleanup\ \>", "Input"], Cell[BoxData[ \(la = 4; lb = 2; Table[Sum[ If[co[la, ma, lb, mb, c, \(-ma\) - mb]\ \((\(-1\))\)^\((\(-ma\) - mb)\) \[Equal] 0, 0, 1]\ ylm[c, ma + mb], {c, Max[Abs[ma + mb], Abs[la - lb]], la + lb}], {ma, \(-la\), la}, {mb, \(-lb\), lb}]\)], "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Polynomials in x, y, z ", "Subsubsection"], Cell[TextData[{ "Since ", Cell[BoxData[ \(\(\((ylm[l, m])\)\^*\)\)]], " = (-1)^m ylm[ l , -m ] we can split the ylm in a real \"px\" or \ cos(\[Phi]) part, and an imaginary part \"py\" of sin(\[Phi]),\nusing \ ylm[1,0] =pz and ylm[l,m]=LegendreP[ l , |m| ] e^(m I \[Phi]) = (P..) \ cos(m\[Phi]) + (P..) I sin(m\[Phi]) and {cos(\[Phi]), I sin(\[Phi])} -> { x \ , y }" }], "Text"], Cell["\<\ (SphericalHarmonicY[1,1,th,fi]- \ SphericalHarmonicY[1,-1,th,fi])/Sqrt[2]//FullSimplify\ \>", "Input"], Cell["\<\ -I (SphericalHarmonicY[1,1,th,fi]+SphericalHarmonicY[1,-1,th,fi])/Sqrt[2]//\ FullSimplify\ \>", "Input"], Cell["\<\ {toxyz}=Solve[{ \ (ylm[1,1]-ylm[1,-1])/Sqrt[2]==px,-I(ylm[1,1]+ylm[1,-1])/Sqrt[2]==py,ylm[1,0]==\ pz}, {ylm[1,1],ylm[1,0],ylm[1,-1]}]//FullSimplify\ \>", "Input", InitializationCell->True], Cell["\<\ fromxyz={px->(ylm[1,1]-ylm[1,-1])/Sqrt[2],py-> \ -I(ylm[1,1]+ylm[1,-1])/Sqrt[2],pz->ylm[1,0]}\ \>", "Input", InitializationCell->True], Cell["{ pz^2 ,px pz, py pz, px^2-py^2, px py}/. fromxyz ", "Input"], Cell["toproduct[%]/. toxyz //Simplify", "Input"], Cell["tosum[%%]//Simplify", "Input"], Cell["\<\ Table[ylm[2,k],{k,-2,2}] %//toproduct //FullSimplify %/. toxyz //FullSimplify %/. fromxyz //FullSimplify %//tosum //FullSimplify\ \>", "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Rotation of the coordinate system", "Subsubsection"], Cell["\<\ after rotation in 3D through z-x-z Euler angles \[Alpha], \[Beta], \[Gamma] the rotated Spherical Harmonics ylm[l, mr ,\[Theta],\[Phi] ] can be written \ as a linear combination of the unrotated ones ylm[l , m=-l,..,l,\[Theta],\ \[Phi] ] see http://en.wikipedia.org/wiki/Wigner_D-matrix#Relation_with_spherical_\ harmonic_functions and http://en.wikipedia.org/wiki/Jacobi_polynomials wignerd[ l , m_rotated, m, \[Alpha],\[Beta],\[Gamma]] gives the coefficient \ of ylm[l, m_rotated] after the action of rotation on ylm[l,m]\ \>", "Text"], Cell["\<\ wignerd[l_,mr_,m_,\[Alpha]_,\[Beta]_,\[Gamma]_]:=(-I)^(mr-m) Exp[I(mr \ \[Alpha]+m \ \[Gamma])]If[Chop[\[Beta]]===0,1,Sqrt[(l+m)!(l-m)!/(l+mr)!/(l-mr)!]Sin[\[Beta]\ /2]^(m-mr)Cos[\[Beta]/2]^(m+mr)JacobiP[l-m,m-mr,m+mr,Cos[\[Beta]]]]\ \>", "Input", InitializationCell->True, Background->RGBColor[1, 1, 0]], Cell["<True], Cell["<True], Cell[TextData[{ "first check the \"overlap\" between ylm[l,m, ", StyleBox["\[Theta]", FontColor->RGBColor[1, 0, 0]], ", ", StyleBox["\[Phi]", FontColor->RGBColor[1, 0, 0]], " ] and ylm[l, ", StyleBox["mr=-l..l", FontColor->RGBColor[1, 0, 1]], ", ", StyleBox["th", FontColor->RGBColor[0, 0, 1]], ", ", StyleBox["fi", FontColor->RGBColor[0, 0, 1]], " ]\nstart with generalised euler Angles" }], "Text"], Cell["{\[Alpha],\[Beta],\[Gamma]}=.", "Input"], Cell["\<\ {\[Theta],\[Phi]}=Rest@CoordinatesFromCartesian[Rotate3D[\ CoordinatesToCartesian[{1,th,fi},Spherical], \ \[Alpha],\[Beta],\[Gamma]],Spherical]//FullSimplify\ \>", "Input"], Cell["now give 'm real values", "Text"], Cell["\<\ {\[Alpha],\[Beta],\[Gamma]}={ \[Pi]/3.,\[Pi]/7., \ \[Pi]/5.};Simplify[{\[Theta],\[Phi]}]\ \>", "Input"], Cell["this takes a minute or so:", "Text"], Cell["\<\ NIntegrate[SphericalHarmonicY[3,-2,th,fi] * (-1)^(1) \ SphericalHarmonicY[3,-(1),\[Theta],\[Phi]] \ Sin[th],{th,0,\[Pi]},{fi,0,2\[Pi]}]\ \>", "Input"], Cell["\<\ rotation applied to ylm[3,1] produces a linear combination where the \ coefficient of ylm[3,-2] is:\ \>", "Text"], Cell["wignerd[3,-2,1,\[Alpha],\[Beta],\[Gamma]]", "Input"], Cell["this takes also a few minutes:", "Text"], Cell["\<\ Table[NIntegrate[SphericalHarmonicY[2,mr,th,fi] (-1)^(m) \ SphericalHarmonicY[2,-(m),\[Theta],\[Phi]] \ Sin[th],{th,0,\[Pi]},{fi,0,2\[Pi]}],{l,2},{m,-l,l},{mr,0,l}]\ \>", "Input"], Cell["\<\ Table[wignerd[2,mr,m,\[Alpha],\[Beta],\[Gamma]],{l,2},{m,-l,l},{mr,0,l}]\ \>", "Input"], Cell["check it:", "Text"], Cell["Chop[%%-% ,10^-9]", "Input"], Cell["Check the ylm of an entire rotated polyhedron:", "Text"], Cell["({1,1,1} #)&/@Vertices[Icosahedron];", "Input"], Cell["Rotate3D[#, \[Alpha],\[Beta],\[Gamma]]&/@%", "Input"], Cell["iconrot=CoordinatesFromCartesian[#,Spherical]&/@ %", "Input"], Cell["intermed11=Function[{a,b,c},Evaluate@(matbc )]@@@iconrot;", "Input"], Cell["\<\ (intermed13=Plus@@(intermed11/. ylm[l_,m_,b_,c_] ->(-1)^m \ SphericalHarmonicY[l,-m,b,c]));\ \>", "Input"], Cell["these are the ylm for the rotated polyhedron:", "Text"], Cell["\<\ Plus@@(Flatten[matbc intermed13] /. {b->Sequence[],c->Sequence[]})//Chop\ \>", "Input"], Cell["here is the unrotated one from before:", "Text"], Cell["sym", "Input"], Cell["\<\ apply the wignerd transformation to it, ylm[4, mr ,\[Theta],\[Phi]] --> Sum[ m=-4..4; wignerd_m ylm[ 4, m th, fi] \ ] and we get the same result:\ \>", "Text"], Cell["\<\ Collect[sym/. ylm[l_,mr_]:>Sum[wignerd[l,mr,m,\[Alpha],\[Beta],\[Gamma]] \ ylm[l,m],{m,-l,l}],_ylm]//Simplify//Chop\ \>", "Input"], Cell["%%%-% //Chop", "Input"] }, Closed]], Cell[CellGroupData[{ Cell["Checking with orthogonal vectors of length 1:2:3", "Subsubsection"], Cell["n=8;(matbc=Table[ ylm[j~Max~i,j-i,b,c],{i,0,n},{j,0,n}] );", "Input"], Cell["\<\ icon=CoordinatesFromCartesian[#,Spherical]&/@ \ {{1,0,0},{0,1,0},{0,1,0},{0,0,1},{0,0,1},{0,0,1}};\ \>", "Input"], Cell["intermed1=N[Function[{a,b,c},Evaluate@matbc]@@@icon];", "Input"], Cell["\<\ intermed2=Chop[N[intermed1 /. ylm[l_,m_,b_,c_] ->(-1)^m \ SphericalHarmonicY[l,-m,b,c]]] ;\ \>", "Input"], Cell["(intermed3=Chop[Plus@@intermed2])//MatrixForm", "Input"], Cell["{\[Alpha],\[Beta],\[Gamma]}", "Input"], Cell["mat=matbc/. ylm[l_,m_,b,c]->ylm[l,m];", "Input"], Cell["\<\ deco=Plus@@(Flatten[intermed3 mat/. ylm[l_,mr_]:>Sum[wignerd[l,mr,m,\[Alpha],\ \[Beta],\[Gamma]] ylm[l,m],{m,-l,l}]]);\ \>", "Input"], Cell["\<\ coeff=Table[Coefficient[deco, ylm[j~Max~i,j-i]],{i,0,n},{j,0,n}];\ \>", "Input"], Cell["(it=coeff //Chop) //MatrixForm", "Input"], Cell["Plus@@Flatten[mat it]", "Input"], Cell["fun=%/. ylm[l_,m_] ->SphericalHarmonicY[l,m,th,fi];", "Input"], Cell["\<\ a1=SphericalPlot3D[{0+Abs[fun],SurfaceColor[ Hue[ \ myArg[fun]]]},{th,0,\[Pi]},{fi,0,2\[Pi]},PlotPoints->60,PlotRange->All]\ \>", "Input"], Cell["\<\ make the vectors long enough to protrude out of the lobes (depends on the \ number of vertices)\ \>", "Text"], Cell["cart= 8 {{1,0,0},{0,2,0},{0,0,3}};", "Input"], Cell["\<\ a2=Graphics3D[{Thickness[.02],Line[{{0,0,0},#}]}&/@(Rotate3D[#,\[Alpha],\ \[Beta],\[Gamma]]&/@cart)]\ \>", "Input"], Cell["check that the vectors coincide with the lobes:", "Text"], Cell["Show[a1,a2]", "Input"], Cell["<", "Subsubsection"], Cell["\<\ Table[ \[LeftAngleBracket]ylm[1,0]^n , ylm[n,0]\[RightAngleBracket]^2 \ \[Pi]^(n-1),{n,12}]//cleanup\ \>", "Input"], Cell["see file \"Y10_nYn0.nb\"", "Text"], Cell["\<\ Table[modn=Mod[n,4];i=Floor[n/4]; \[Pi]^Floor[n/2-1/2] \ 5^(-Floor[n/2])w[1,n-1]^Mod[n,2] w[2,2]^i \ Switch[modn,0|1,Times@@Table[w[4,k],{k,4,4i-4,4}],2|3,If[i>0,w[2,4],1]If[i>1,\ w[6,4i-4],1] Times@@Table[w[4,k],{k,4,4i-8,4}],_,1] ,{n,2,12}] /. \ w[u_,v_]->co[u,0,v,0,u+v,0]^2\ \>", "Input"] }, Closed]] }, Open ]] }, FrontEndVersion->"4.0 for Microsoft Windows", ScreenRectangle->{{0, 1680}, {0, 977}}, AutoGeneratedPackage->None, WindowSize->{771, 651}, WindowMargins->{{4, Automatic}, {Automatic, 5}} ] (*********************************************************************** Cached data follows. If you edit this Notebook file directly, not using Mathematica, you must remove the line containing CacheID at the top of the file. The cache data will then be recreated when you save this file from within Mathematica. ***********************************************************************) (*CellTagsOutline CellTagsIndex->{} *) (*CellTagsIndex CellTagsIndex->{} *) (*NotebookFileOutline Notebook[{ Cell[CellGroupData[{ Cell[1739, 51, 184, 6, 93, "Subtitle", Evaluatable->False], Cell[1926, 59, 37, 0, 33, "Text"], Cell[1966, 61, 226, 6, 33, "Text"], Cell[2195, 69, 68, 0, 33, "Text"], Cell[CellGroupData[{ Cell[2288, 73, 40, 0, 43, "Subsubsection"], Cell[2331, 75, 67, 1, 30, "Input", InitializationCell->True], Cell[2401, 78, 75, 1, 33, "Text", Evaluatable->False], Cell[2479, 81, 232, 6, 66, "Input", InitializationCell->True], Cell[2714, 89, 41, 0, 33, "Text"], Cell[2758, 91, 372, 8, 120, "Input", InitializationCell->True], Cell[3133, 101, 96, 1, 30, "Input", InitializationCell->True], Cell[3232, 104, 235, 6, 66, "Input", InitializationCell->True], Cell[3470, 112, 98, 1, 30, "Input", InitializationCell->True] }, Closed]], Cell[CellGroupData[{ Cell[3605, 118, 314, 9, 46, "Subsubsection"], Cell[3922, 129, 74, 1, 33, "Text", Evaluatable->False], Cell[3999, 132, 46, 0, 30, "Input"], Cell[4048, 134, 146, 4, 33, "Text", Evaluatable->False], Cell[4197, 140, 73, 1, 30, "Input"], Cell[4273, 143, 100, 1, 30, "Input"], Cell[4376, 146, 29, 0, 30, "Input"], Cell[4408, 148, 25, 0, 30, "Input"], Cell[4436, 150, 114, 3, 33, "Text"], Cell[4553, 155, 70, 4, 48, "Input"], Cell[4626, 161, 25, 0, 30, "Input"], Cell[4654, 163, 88, 2, 33, "Text"], Cell[4745, 167, 142, 5, 48, "Input"], Cell[4890, 174, 58, 1, 30, "Input"], Cell[4951, 177, 78, 1, 30, "Input"], Cell[5032, 180, 25, 0, 30, "Input"], Cell[5060, 182, 29, 0, 30, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[5126, 187, 77, 0, 29, "Subsubsection"], Cell[5206, 189, 30, 0, 30, "Input"], Cell[5239, 191, 29, 0, 30, "Input"], Cell[5271, 193, 73, 1, 30, "Input", InitializationCell->True], Cell[5347, 196, 66, 1, 30, "Input", InitializationCell->True], Cell[5416, 199, 66, 1, 30, "Input", InitializationCell->True], Cell[5485, 202, 108, 3, 30, "Input", InitializationCell->True], Cell[5596, 207, 38, 0, 30, "Input"], Cell[5637, 209, 65, 0, 30, "Input"], Cell[5705, 211, 56, 0, 33, "Text"], Cell[5764, 213, 75, 0, 30, "Input"], Cell[5842, 215, 459, 7, 90, "Text"], Cell[6304, 224, 70, 0, 30, "Input"], Cell[6377, 226, 208, 4, 52, "Text"], Cell[6588, 232, 116, 3, 30, "Input"], Cell[6707, 237, 56, 0, 33, "Text"], Cell[6766, 239, 62, 0, 30, "Input"], Cell[6831, 241, 71, 0, 30, "Input"], Cell[6905, 243, 155, 3, 33, "Text"], Cell[7063, 248, 92, 2, 30, "Input"], Cell[7158, 252, 73, 0, 33, "Text"], Cell[7234, 254, 68, 0, 30, "Input"], Cell[7305, 256, 139, 3, 48, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[7481, 264, 295, 10, 29, "Subsubsection"], Cell[7779, 276, 71, 0, 30, "Input"], Cell[7853, 278, 384, 8, 52, "Text"], Cell[8240, 288, 135, 4, 30, "Input", InitializationCell->True], Cell[8378, 294, 134, 4, 30, "Input", InitializationCell->True], Cell[8515, 300, 131, 4, 30, "Input", InitializationCell->True], Cell[8649, 306, 935, 18, 156, "Input", InitializationCell->True], Cell[9587, 326, 209, 5, 48, "Input", InitializationCell->True], Cell[9799, 333, 100, 1, 30, "Input", InitializationCell->True], Cell[9902, 336, 129, 3, 30, "Input"], Cell[10034, 341, 86, 1, 30, "Input"], Cell[10123, 344, 118, 3, 30, "Input"], Cell[10244, 349, 118, 4, 30, "Input"], Cell[10365, 355, 31, 0, 30, "Input"], Cell[10399, 357, 35, 0, 30, "Input"], Cell[10437, 359, 42, 0, 30, "Input"], Cell[10482, 361, 124, 3, 30, "Input"], Cell[10609, 366, 311, 6, 70, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[10957, 377, 49, 0, 29, "Subsubsection"], Cell[11009, 379, 397, 9, 52, "Text"], Cell[11409, 390, 112, 3, 30, "Input"], Cell[11524, 395, 114, 3, 30, "Input"], Cell[11641, 400, 200, 5, 30, "Input", InitializationCell->True], Cell[11844, 407, 146, 4, 30, "Input", InitializationCell->True], Cell[11993, 413, 67, 0, 30, "Input"], Cell[12063, 415, 48, 0, 30, "Input"], Cell[12114, 417, 36, 0, 30, "Input"], Cell[12153, 419, 153, 6, 102, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[12343, 430, 58, 0, 29, "Subsubsection"], Cell[12404, 432, 550, 9, 90, "Text"], Cell[12957, 443, 319, 7, 64, "Input", InitializationCell->True], Cell[13279, 452, 71, 1, 30, "Input", InitializationCell->True], Cell[13353, 455, 66, 1, 30, "Input", InitializationCell->True], Cell[13422, 458, 442, 17, 52, "Text"], Cell[13867, 477, 46, 0, 30, "Input"], Cell[13916, 479, 182, 4, 48, "Input"], Cell[14101, 485, 39, 0, 33, "Text"], Cell[14143, 487, 113, 3, 30, "Input"], Cell[14259, 492, 42, 0, 33, "Text"], Cell[14304, 494, 160, 4, 48, "Input"], Cell[14467, 500, 123, 3, 33, "Text"], Cell[14593, 505, 58, 0, 30, "Input"], Cell[14654, 507, 46, 0, 33, "Text"], Cell[14703, 509, 189, 4, 48, "Input"], Cell[14895, 515, 97, 2, 30, "Input"], Cell[14995, 519, 25, 0, 33, "Text"], Cell[15023, 521, 34, 0, 30, "Input"], Cell[15060, 523, 62, 0, 33, "Text"], Cell[15125, 525, 53, 0, 30, "Input"], Cell[15181, 527, 59, 0, 30, "Input"], Cell[15243, 529, 67, 0, 30, "Input"], Cell[15313, 531, 74, 0, 30, "Input"], Cell[15390, 533, 116, 3, 30, "Input"], Cell[15509, 538, 61, 0, 33, "Text"], Cell[15573, 540, 97, 2, 30, "Input"], Cell[15673, 544, 54, 0, 33, "Text"], Cell[15730, 546, 20, 0, 30, "Input"], Cell[15753, 548, 174, 5, 71, "Text"], Cell[15930, 555, 141, 3, 30, "Input"], Cell[16074, 560, 29, 0, 30, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[16140, 565, 73, 0, 29, "Subsubsection"], Cell[16216, 567, 75, 0, 30, "Input"], Cell[16294, 569, 123, 3, 30, "Input"], Cell[16420, 574, 70, 0, 30, "Input"], Cell[16493, 576, 115, 3, 30, "Input"], Cell[16611, 581, 62, 0, 30, "Input"], Cell[16676, 583, 44, 0, 30, "Input"], Cell[16723, 585, 54, 0, 30, "Input"], Cell[16780, 587, 143, 3, 30, "Input"], Cell[16926, 592, 90, 2, 30, "Input"], Cell[17019, 596, 47, 0, 30, "Input"], Cell[17069, 598, 38, 0, 30, "Input"], Cell[17110, 600, 68, 0, 30, "Input"], Cell[17181, 602, 148, 3, 48, "Input"], Cell[17332, 607, 119, 3, 33, "Text"], Cell[17454, 612, 51, 0, 30, "Input"], Cell[17508, 614, 125, 3, 30, "Input"], Cell[17636, 619, 63, 0, 33, "Text"], Cell[17702, 621, 28, 0, 30, "Input"], Cell[17733, 623, 30, 0, 30, "Input"], Cell[17766, 625, 29, 0, 30, "Input"] }, Closed]], Cell[CellGroupData[{ Cell[17832, 630, 111, 3, 29, "Subsubsection"], Cell[17946, 635, 126, 3, 30, "Input"], Cell[18075, 640, 40, 0, 33, "Text"], Cell[18118, 642, 302, 6, 66, "Input"] }, Closed]] }, Open ]] } ] *) (*********************************************************************** End of Mathematica Notebook file. ***********************************************************************)