本文中で使用したＭａｔｈｅｍａｔｉｃａのソースです。
本文に合わせ随時変更していきます。 本文と突き合わせて実行し、ご理解の足しにしていただければと思います。 ＴＥＸＴベースでコピーして個人の範囲でご利用ください。
 全ソースですので、一挙に実行できます。ただしメイの実験と同様、各項目毎にコピーして順次実行する方が理解しやすいでしょう。 但し、各項目では以前の計算結果を利用しています。 順番を変える場合はご注意ください。ＩｎｉｔｉａｌａｉｚａｔｉｏｎではＳｐｈｅｒｅ(球面）かTorus(ドーナッツ）を選んでください。 (* コメント・・・ *) のように不要な方をコメントアウトして使ってください。Ｍ＝４とすれば、四次元まで拡張できます。その場合は計量の拡張を合わせて行ってください。 Off[General::spell]; Off[General::spell1]; Clear["Global'*"] x={x1,x2,x3,x4} (* Example of maximum dimension M=4 gxx=DiagonalMatrix[ 1,-x1^2,-x1^3,-x1^4 ] *) M=2; (* Initialization for Sphere ga=1; X=ga*Sin[x1]Sin[x2]; Y=ga*Sin[x1]Cos[x2]; Z=ga*Cos[x1]; ParametricPlot3D[{X,Y,Z},{x1,0,Pi},{x2,0,2Pi}] gxx=DiagonalMatrix[a^2,a^2 Sin[x1]^2 ] *) (* Initialization for Torus *) ga=1;gb=2; X=(gb+ga*Cos[x1])Sin[x2]; Y=(gb+ga*Cos[x1])Cos[x2]; Z=ga*Sin[x1]; ParametricPlot3D[{X,Y,Z},{x1,0,2Pi},{x2,0,2Pi}] gxx=DiagonalMatrix[a^2,(b+a*Sin[x1])^2 ] Igxx=Inverse[gxx] (* 1'st Christoffel *) Chr1=Table[D[gxx[[i,j]],x[[k]]] +D[gxx[[i,k]],x[[j]]] -D[gxx[[j,k]],x[[i]]], {i,M},{j,M},{k,M}]/2 //ExpandAll//Simplify (* 2'nd Christoffel *) Chr2=Table[Sum[Igxx[[i,l]]Chr1[[l,j,k]],{l,M}], {i,M},{j,M},{k,M}]//ExpandAll//Simplify Table[Chr1[[i,j,k]]-Chr1[[j,i,k]],{i,2},{j,2},{k,2}] Table[Chr1[[i,j,k]]-Chr1[[i,k,j]],{i,2},{j,2},{k,2}] Table[Chr2[[i,j,k]]-Chr2[[i,k,j]],{i,2},{j,2},{k,2}] (* Curvature tensor *) DChr=Table[ D[Chr2[[h,k,i]],x[[j]]] -D[Chr2[[h,j,i]],x[[k]]], {h,M},{i,M},{j,M},{k,M} ] //ExpandAll//Simplify CChr=Table[ Sum[ Chr2[[h,j,l]]Chr2[[l,k,i]] -Chr2[[h,k,l]]Chr2[[l,j,i]], {l,M}], {h,M},{i,M},{j,M},{k,M} ]//ExpandAll//Simplify R4=DChr+CChr //ExpandAll//Simplify cR4=Table[Sum[gxx[[h,l]]R4[[l,i,j,k]],{l,M}], {h,M},{i,M},{j,M},{k,M} ] %//MatrixForm Table[cR4[[h,i,j,k]]+cR4[[h,i,k,j]], {h,2},{i,2},{j,2},{k,2} ]//ExpandAll//Simplify Table[cR4[[h,i,j,k]]+cR4[[i,h,j,k]], {h,2},{i,2},{j,2},{k,2} ]//ExpandAll//Simplify Table[cR4[[h,i,j,k]]+cR4[[i,h,j,k]], {h,2},{i,2},{j,2},{k,2} ]//ExpandAll//Simplify Table[R4[[h,i,j,k]]+R4[[h,j,k,i]]+R4[[h,k,i,j]], {h,M},{i,M},{j,M},{k,M} ]//ExpandAll//Simplify (* Bianchi identities *) bi1=Table[D[R4[[h,i,j,k]],x[[l]]] +Sum[Chr2[[h,l,m]]R4[[m,i,j,k]],{m,M}] -Sum[Chr2[[m,l,i]]R4[[h,m,j,k]],{m,M}] -Sum[Chr2[[m,l,j]]R4[[h,i,m,k]],{m,M}] -Sum[Chr2[[m,l,k]]R4[[h,i,j,m]],{m,M}], {h,M},{i,M},{j,M},{k,M},{l,M} ] //ExpandAll //Simplify bi2=Table[bi1[[h,i,k,l,j]], {h,M},{i,M},{j,M},{k,M},{l,M} ] //ExpandAll //Simplify bi3=Table[bi1[[h,i,l,j,k]], {h,M},{i,M},{j,M},{k,M},{l,M} ] //ExpandAll //Simplify Bianchi=bi1+bi2+bi3 //ExpandAll //Simplify (* Contracted Bianchi identities *) cntbi1=Table[Sum[bi1[[h,i,j,k,h]],{h,M}], {i,M},{j,M},{k,M}] //ExpandAll//Simplify cntbi2=Table[Sum[bi1[[h,i,k,h,j]],{h,M}], {i,M},{j,M},{k,M}] //ExpandAll//Simplify cntbi3=Table[Sum[bi1[[h,i,h,j,k]],{h,M}], {i,M},{j,M},{k,M}] //ExpandAll//Simplify cntBI=cntbi1+cntbi2+cntbi3 cnt2Bi1=Table[Sum[Igxx[[i,j]]cntbi1[[i,j,k]], {i,M},{j,M}], {k,M}] //ExpandAll//Simplify cnt2Bi2=Table[Sum[Igxx[[i,j]]cntbi2[[i,j,k]], {i,M},{j,M}], {k,M}] //ExpandAll//Simplify cnt2Bi3=Table[Sum[Igxx[[i,j]]cntbi3[[i,j,k]], {i,M},{j,M}], {k,M}] //ExpandAll//Simplify cntBianchi=cnt2Bi1+ cnt2Bi2+ cnt2Bi3 //ExpandAll//Simplify (* Ricci tensor *) R2=Table[ Sum[R4[[h,i,j,h]],{h,M}],{i,M},{j,M} ] //ExpandAll//Simplify Table[ R2[[i,j]]-R2[[j,i]],{i,M},{j,M} ] //ExpandAll//Simplify (* Scalar curvature *) R=Sum[ Igxx[[i,j]]R2[[i,j]],{i,M},{j,M} ] //ExpandAll//Simplify (* Graphic of the R *) a=ga; b=gb; Plot3D[R,{x1,0,2Pi},{x2,0,2Pi}, AxesLabel->{x1,x2,"R"}, PlotPoints->20] Clear[a,b] (*Einstein tensor *) G=R2-gxx*R/2 //ExpandAll//Simplify cdG=Table[Sum[D[G[[h,i]],x[[h]]]+ Chr2[[h,l,h]]G[[l,i]]- Chr2[[l,i,h]]G[[h,l]], {h,M},{l,M}], {i,M}] //ExpandAll//Simplify |