Problem 2

Clear[coord, metric,inversemetric, affine, riemann, lriemann, uriemann, ricci, scalar, einstein,weyl, geodesic,R,G,τ, i,j,k,l,s];
Clear[r,θ,ϕ,t,χ,a,m]; 

(*----------------------------------------------------------------------------*)
(* This is what you need to set: *)
coord = {θ,ϕ};
n          =Length[coord];
metric={
{(a^2),                  0},
{0  ,(a^2) ((Sin[θ])^2)}};
(*----------------------------------------------------------------------------*)

inversemetric=FullSimplify[Inverse[metric]];
Print["-----------------------------------------------------------------------"];
Print["The Manifold has dimension   n= ",n,"\nCoordinate system:          ",coord];
Print["-----------------------------------------------------------------------"];
Print["(Subscript[g, μν])=",metric//MatrixForm];
Print["(g^(μν))=",inversemetric//MatrixForm];
Print["g  =",Det[metric]//FullSimplify];
affine:=affine=FullSimplify[Table[
(1/2)*Sum[
(*              (g^is) ((∂_k)(Subscript[g, sj])+(∂_j)(Subscript[g, sk])-(∂_s)(Subscript[g, jk]))           *)
(inversemetric[[i,s]])*
(D[metric[[s,j]],coord[[k]] ]+D[metric[[s,k]],coord[[j]] ]-D[metric[[j,k]],coord[[s]] ]),
{s,1,n}],
{i,1,n},{j,1,n},{k,1,n}] ];
(*The non zero Christoffel symbols are computed and selected below: *)
listaffine:=Table[
If[
UnsameQ[affine[[i,j,k]],0],
{Subscript[Superscript[Γ,i],j,k],affine[[i,j,k]]}
  ] ,
{i,1,n},{j,1,n},{k,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Christoffel Symbols:"];
Print[TableForm[Partition[DeleteCases[Flatten[listaffine],Null],2],TableSpacing->{2,2}]];
riemann:=riemann=FullSimplify[Table[
(* (Subscript[(R^i), jkl])=    (∂_k)(Subscript[(Γ^i), lj])                   -         (∂_l)(Subscript[(Γ^i), kj])*)
D[       affine[[i,l,j]],  coord[[k]]           ]-D[affine[[i,k,j]], coord[[l]]          ]+
(*         (Subscript[(Γ^i), ks])             (Subscript[(Γ^s), lj])     -         (Subscript[(Γ^i), ls])            (Subscript[(Γ^s), kj])      *)
Sum[affine[[i,k,s]]affine[[s,l,j]] -    affine[[i,l,s]] affine[[s,k,j]] ,
{s,1,n}],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}] ];
listriemann:=Table[
If[
UnsameQ[riemann[[i,j,k,l]],0],
{Subscript[Superscript[R,i],j,k,l],riemann[[i,j,k,l]]}
] ,
{i,1,n},{j,1,n},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listriemann],Null],2],TableSpacing->{2,2}]];
lriemann:=lriemann=FullSimplify[Table[
Sum[metric[[i,ii]] riemann[[ii,j,k,l]],{ii,1,n}],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listlriemann:=Table[
If[
UnsameQ[lriemann[[i,j,k,l]],0],
{Subscript[R,i,j,k,l],lriemann[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Contravariant Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listlriemann],Null],2],TableSpacing->{2,2}]];
uriemann:=uriemann=FullSimplify[Table[
Sum[
inversemetric[[j,jj]] inversemetric[[k,kk]] inversemetric[[l,ll]] riemann[[i,jj,kk,ll]],{jj,1,n},{kk,1,n},{ll,1,n}
],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listuriemann:=Table[
If[
UnsameQ[uriemann[[i,j,k,l]],0],{Superscript[Superscript[Superscript[Superscript[R,i],j],k],l],uriemann[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Covariant Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listuriemann],Null],2],TableSpacing->{2,2}]];
r2=FullSimplify[Sum[lriemann[[i,j,k,l]]uriemann[[i,j,k,l]],{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
Print["-----------------------------------------------------------------------"];
Print["(R^2)= ",r2];
ricci:=ricci=FullSimplify[Table[
Sum[
riemann[[i,j,i,l]],
{i,1,n}
],{j,1,n},{l,1,n}] ];
listricci:=Table[
If[
UnsameQ[ricci[[j,l]],0],
{Subscript[R,j,l],ricci[[j,l]]}
] ,{j,1,n},{l,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Ricci Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listricci],Null],2],TableSpacing->{2,2}]];
scalar=FullSimplify[Sum[inversemetric[[i,j]]ricci[[i,j]],{i,1,n},{j,1,n}] ];
Print["-----------------------------------------------------------------------"];
Print["Curvature Scalar:"];
Print["R= ",scalar];
einstein:=einstein=FullSimplify[ricci-(1/2)scalar*metric];
listeinstein:=Table[
If[
UnsameQ[einstein[[j,l]],0],
{Subscript[G,j,l],einstein[[j,l]]}
] ,{j,1,n},{l,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Einstein Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listeinstein],Null],2],TableSpacing->{2,2}]];
weyl:=weyl=FullSimplify[Table[
If[n>3,
lriemann[[i,j,k,l]]
-         (1/(n-2))           (metric[[i,k]] ricci[[l,j]] -metric[[i,l]] ricci[[k,j]]-metric[[j,k]] ricci[[l,i]]+metric[[j,l]] ricci[[k,i]])
+(1/((n-1)(n-2)))(metric[[i,k]] metric[[l,j]]-metric[[i,l]] metric[[k,j]]) scalar
(*else, if n<= 3 return 0:*),0],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listweyl:=Table[
If[
UnsameQ[weyl[[i,j,k,l]],0],
{Subscript[ℭ,i,j,k,l],weyl[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Weyl Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listweyl],Null],2],TableSpacing->{2,2}]];
geodesic:=geodesic=Simplify[Table[-Sum[affine[[i,j,k]]u[j]u[k],{j,1,n},{k,1,n}],{i,1,n}]];
subst = Table[u[i]-> Subscript[coord[[i]],τ],{i,1,n}];
nlistgeodesic:=Table[{Subscript[coord[[i]],ττ],"+",-geodesic[[i]]/.subst,"= 0"},{i,1,n}];
Print["-----------------------------------------------------------------------"];
Print["Geodesic Equations:"];
Print[TableForm[nlistgeodesic,TableSpacing->{2}]];

Problem 4

Clear[coord, metric,inversemetric, affine, riemann, lriemann, uriemann, ricci, scalar, einstein,weyl, geodesic,R,G,τ, i,j,k,l,s];
Clear[r,θ,ϕ,t,χ,a,m,Ω]; 

(*----------------------------------------------------------------------------*)
(* This is what you need to set: *)
coord = {t,x,y,z};
n          =Length[coord];
metric={
{-(1-(Ω^2)((x^2)+(y^2))), Ω y, -Ω x, 0},
{   Ω y                           ,    1 ,  0    ,0},
{-Ω x                            ,    0,  1    , 0},
{  0                                ,     0,  0  ,  1}
};
(*----------------------------------------------------------------------------*)

inversemetric=FullSimplify[Inverse[metric]];
Print["-----------------------------------------------------------------------"];
Print["The Manifold has dimension   n= ",n,"\nCoordinate system:          ",coord];
Print["-----------------------------------------------------------------------"];
Print["(Subscript[g, μν])=",metric//MatrixForm];
Print["(g^(μν))=",inversemetric//MatrixForm];
Print["g  =",Det[metric]//FullSimplify];
affine:=affine=FullSimplify[Table[
(1/2)*Sum[
(*              (g^is) ((∂_k)(Subscript[g, sj])+(∂_j)(Subscript[g, sk])-(∂_s)(Subscript[g, jk]))           *)
(inversemetric[[i,s]])*
(D[metric[[s,j]],coord[[k]] ]+D[metric[[s,k]],coord[[j]] ]-D[metric[[j,k]],coord[[s]] ]),
{s,1,n}],
{i,1,n},{j,1,n},{k,1,n}] ];
(*The non zero Christoffel symbols are computed and selected below: *)
listaffine:=Table[
If[
UnsameQ[affine[[i,j,k]],0],
{Subscript[Superscript[Γ,i],j,k],affine[[i,j,k]]}
  ] ,
{i,1,n},{j,1,n},{k,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Christoffel Symbols:"];
Print[TableForm[Partition[DeleteCases[Flatten[listaffine],Null],2],TableSpacing->{2,2}]];
riemann:=riemann=FullSimplify[Table[
(* (Subscript[(R^i), jkl])=    (∂_k)(Subscript[(Γ^i), lj])                   -         (∂_l)(Subscript[(Γ^i), kj])*)
D[       affine[[i,l,j]],  coord[[k]]           ]-D[affine[[i,k,j]], coord[[l]]          ]+
(*         (Subscript[(Γ^i), ks])             (Subscript[(Γ^s), lj])     -         (Subscript[(Γ^i), ls])            (Subscript[(Γ^s), kj])      *)
Sum[affine[[i,k,s]]affine[[s,l,j]] -    affine[[i,l,s]] affine[[s,k,j]] ,
{s,1,n}],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}] ];
listriemann:=Table[
If[
UnsameQ[riemann[[i,j,k,l]],0],
{Subscript[Superscript[R,i],j,k,l],riemann[[i,j,k,l]]}
] ,
{i,1,n},{j,1,n},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listriemann],Null],2],TableSpacing->{2,2}]];
lriemann:=lriemann=FullSimplify[Table[
Sum[metric[[i,ii]] riemann[[ii,j,k,l]],{ii,1,n}],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listlriemann:=Table[
If[
UnsameQ[lriemann[[i,j,k,l]],0],
{Subscript[R,i,j,k,l],lriemann[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Contravariant Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listlriemann],Null],2],TableSpacing->{2,2}]];
uriemann:=uriemann=FullSimplify[Table[
Sum[
inversemetric[[j,jj]] inversemetric[[k,kk]] inversemetric[[l,ll]] riemann[[i,jj,kk,ll]],{jj,1,n},{kk,1,n},{ll,1,n}
],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listuriemann:=Table[
If[
UnsameQ[uriemann[[i,j,k,l]],0],{Superscript[Superscript[Superscript[Superscript[R,i],j],k],l],uriemann[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Covariant Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listuriemann],Null],2],TableSpacing->{2,2}]];
r2=FullSimplify[Sum[lriemann[[i,j,k,l]]uriemann[[i,j,k,l]],{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
Print["-----------------------------------------------------------------------"];
Print["(R^2)= ",r2];
ricci:=ricci=FullSimplify[Table[
Sum[
riemann[[i,j,i,l]],
{i,1,n}
],{j,1,n},{l,1,n}] ];
listricci:=Table[
If[
UnsameQ[ricci[[j,l]],0],
{Subscript[R,j,l],ricci[[j,l]]}
] ,{j,1,n},{l,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Ricci Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listricci],Null],2],TableSpacing->{2,2}]];
scalar=FullSimplify[Sum[inversemetric[[i,j]]ricci[[i,j]],{i,1,n},{j,1,n}] ];
Print["-----------------------------------------------------------------------"];
Print["Curvature Scalar:"];
Print["R= ",scalar];
einstein:=einstein=FullSimplify[ricci-(1/2)scalar*metric];
listeinstein:=Table[
If[
UnsameQ[einstein[[j,l]],0],
{Subscript[G,j,l],einstein[[j,l]]}
] ,{j,1,n},{l,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Einstein Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listeinstein],Null],2],TableSpacing->{2,2}]];
weyl:=weyl=FullSimplify[Table[
If[n>3,
lriemann[[i,j,k,l]]
-         (1/(n-2))           (metric[[i,k]] ricci[[l,j]] -metric[[i,l]] ricci[[k,j]]-metric[[j,k]] ricci[[l,i]]+metric[[j,l]] ricci[[k,i]])
+(1/((n-1)(n-2)))(metric[[i,k]] metric[[l,j]]-metric[[i,l]] metric[[k,j]]) scalar
(*else, if n<= 3 return 0:*),0],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listweyl:=Table[
If[
UnsameQ[weyl[[i,j,k,l]],0],
{Subscript[ℭ,i,j,k,l],weyl[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Weyl Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listweyl],Null],2],TableSpacing->{2,2}]];
geodesic:=geodesic=Simplify[Table[-Sum[affine[[i,j,k]]u[j]u[k],{j,1,n},{k,1,n}],{i,1,n}]];
subst = Table[u[i]-> Subscript[coord[[i]],τ],{i,1,n}];
nlistgeodesic:=Table[{Subscript[coord[[i]],ττ],"+",-geodesic[[i]]/.subst,"= 0"},{i,1,n}];
Print["-----------------------------------------------------------------------"];
Print["Geodesic Equations:"];
Print[TableForm[nlistgeodesic,TableSpacing->{2}]];

Problem 12

Clear[coord, metric,inversemetric, affine, riemann, lriemann, uriemann, ricci, scalar, einstein,weyl, geodesic,R,G,τ, i,j,k,l,s];
Clear[r,θ,ϕ,t,χ,a,m,x,y]; 

(*----------------------------------------------------------------------------*)
(* This is what you need to set: *)
coord = {x,y};
n          =Length[coord];
metric={
{(y^(-2)),   0},
{0   ,(y^(-2))}};
(*----------------------------------------------------------------------------*)

inversemetric=FullSimplify[Inverse[metric]];
Print["-----------------------------------------------------------------------"];
Print["The Manifold has dimension   n= ",n,"\nCoordinate system:          ",coord];
Print["-----------------------------------------------------------------------"];
Print["(Subscript[g, μν])=",metric//MatrixForm];
Print["(g^(μν))=",inversemetric//MatrixForm];
Print["g  =",Det[metric]//FullSimplify];
affine:=affine=FullSimplify[Table[
(1/2)*Sum[
(*              (g^is) ((∂_k)(Subscript[g, sj])+(∂_j)(Subscript[g, sk])-(∂_s)(Subscript[g, jk]))           *)
(inversemetric[[i,s]])*
(D[metric[[s,j]],coord[[k]] ]+D[metric[[s,k]],coord[[j]] ]-D[metric[[j,k]],coord[[s]] ]),
{s,1,n}],
{i,1,n},{j,1,n},{k,1,n}] ];
(*The non zero Christoffel symbols are computed and selected below: *)
listaffine:=Table[
If[
UnsameQ[affine[[i,j,k]],0],
{Subscript[Superscript[Γ,i],j,k],affine[[i,j,k]]}
  ] ,
{i,1,n},{j,1,n},{k,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Christoffel Symbols:"];
Print[TableForm[Partition[DeleteCases[Flatten[listaffine],Null],2],TableSpacing->{2,2}]];
riemann:=riemann=FullSimplify[Table[
(* (Subscript[(R^i), jkl])=    (∂_k)(Subscript[(Γ^i), lj])                   -         (∂_l)(Subscript[(Γ^i), kj])*)
D[       affine[[i,l,j]],  coord[[k]]           ]-D[affine[[i,k,j]], coord[[l]]          ]+
(*         (Subscript[(Γ^i), ks])             (Subscript[(Γ^s), lj])     -         (Subscript[(Γ^i), ls])            (Subscript[(Γ^s), kj])      *)
Sum[affine[[i,k,s]]affine[[s,l,j]] -    affine[[i,l,s]] affine[[s,k,j]] ,
{s,1,n}],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}] ];
listriemann:=Table[
If[
UnsameQ[riemann[[i,j,k,l]],0],
{Subscript[Superscript[R,i],j,k,l],riemann[[i,j,k,l]]}
] ,
{i,1,n},{j,1,n},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listriemann],Null],2],TableSpacing->{2,2}]];
lriemann:=lriemann=FullSimplify[Table[
Sum[metric[[i,ii]] riemann[[ii,j,k,l]],{ii,1,n}],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listlriemann:=Table[
If[
UnsameQ[lriemann[[i,j,k,l]],0],
{Subscript[R,i,j,k,l],lriemann[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Contravariant Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listlriemann],Null],2],TableSpacing->{2,2}]];
uriemann:=uriemann=FullSimplify[Table[
Sum[
inversemetric[[j,jj]] inversemetric[[k,kk]] inversemetric[[l,ll]] riemann[[i,jj,kk,ll]],{jj,1,n},{kk,1,n},{ll,1,n}
],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listuriemann:=Table[
If[
UnsameQ[uriemann[[i,j,k,l]],0],{Superscript[Superscript[Superscript[Superscript[R,i],j],k],l],uriemann[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Covariant Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listuriemann],Null],2],TableSpacing->{2,2}]];
r2=FullSimplify[Sum[lriemann[[i,j,k,l]]uriemann[[i,j,k,l]],{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
Print["-----------------------------------------------------------------------"];
Print["(R^2)= ",r2];
ricci:=ricci=FullSimplify[Table[
Sum[
riemann[[i,j,i,l]],
{i,1,n}
],{j,1,n},{l,1,n}] ];
listricci:=Table[
If[
UnsameQ[ricci[[j,l]],0],
{Subscript[R,j,l],ricci[[j,l]]}
] ,{j,1,n},{l,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Ricci Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listricci],Null],2],TableSpacing->{2,2}]];
scalar=FullSimplify[Sum[inversemetric[[i,j]]ricci[[i,j]],{i,1,n},{j,1,n}] ];
Print["-----------------------------------------------------------------------"];
Print["Curvature Scalar:"];
Print["R= ",scalar];
einstein:=einstein=FullSimplify[ricci-(1/2)scalar*metric];
listeinstein:=Table[
If[
UnsameQ[einstein[[j,l]],0],
{Subscript[G,j,l],einstein[[j,l]]}
] ,{j,1,n},{l,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Einstein Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listeinstein],Null],2],TableSpacing->{2,2}]];
weyl:=weyl=FullSimplify[Table[
If[n>3,
lriemann[[i,j,k,l]]
-         (1/(n-2))           (metric[[i,k]] ricci[[l,j]] -metric[[i,l]] ricci[[k,j]]-metric[[j,k]] ricci[[l,i]]+metric[[j,l]] ricci[[k,i]])
+(1/((n-1)(n-2)))(metric[[i,k]] metric[[l,j]]-metric[[i,l]] metric[[k,j]]) scalar
(*else, if n<= 3 return 0:*),0],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listweyl:=Table[
If[
UnsameQ[weyl[[i,j,k,l]],0],
{Subscript[ℭ,i,j,k,l],weyl[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Weyl Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listweyl],Null],2],TableSpacing->{2,2}]];
geodesic:=geodesic=Simplify[Table[-Sum[affine[[i,j,k]]u[j]u[k],{j,1,n},{k,1,n}],{i,1,n}]];
subst = Table[u[i]-> Subscript[coord[[i]],τ],{i,1,n}];
nlistgeodesic:=Table[{Subscript[coord[[i]],ττ],"+",-geodesic[[i]]/.subst,"= 0"},{i,1,n}];
Print["-----------------------------------------------------------------------"];
Print["Geodesic Equations:"];
Print[TableForm[nlistgeodesic,TableSpacing->{2}]];

Integrate[(y/R)(((1-((y^2)/(R^2))))^(-1/2)),y,Assumptions-> R>0 && y>0 && y<R]

Integrate[(y^(-1))(((1-((y^2)/(R^2))))^(-1/2)),y,Assumptions-> R>0 && y>0 && y<R]

Problem 8, Carroll

Clear[coord, metric,inversemetric, affine, riemann, lriemann, uriemann, ricci, scalar, einstein,weyl, geodesic,R,G,τ, i,j,k,l,s];
Clear[r,θ,ϕ,t,χ,a,m,x,y,ψ]; 

(*----------------------------------------------------------------------------*)
(* This is what you need to set: *)
coord = {ψ,θ,ϕ};
n          =Length[coord];
metric={
{1 , 0             , 0                            },
{0 , ((Sin[ψ])^2),0                             },
{0 , 0             ,((Sin[ψ])^2) ((Sin[θ])^2)}};
(*----------------------------------------------------------------------------*)

inversemetric=FullSimplify[Inverse[metric]];
Print["-----------------------------------------------------------------------"];
Print["The Manifold has dimension   n= ",n,"\nCoordinate system:          ",coord];
Print["-----------------------------------------------------------------------"];
Print["(Subscript[g, μν])=",metric//MatrixForm];
Print["(g^(μν))=",inversemetric//MatrixForm];
Print["g  =",Det[metric]//FullSimplify];
affine:=affine=FullSimplify[Table[
(1/2)*Sum[
(*              (g^is) ((∂_k)(Subscript[g, sj])+(∂_j)(Subscript[g, sk])-(∂_s)(Subscript[g, jk]))           *)
(inversemetric[[i,s]])*
(D[metric[[s,j]],coord[[k]] ]+D[metric[[s,k]],coord[[j]] ]-D[metric[[j,k]],coord[[s]] ]),
{s,1,n}],
{i,1,n},{j,1,n},{k,1,n}] ];
(*The non zero Christoffel symbols are computed and selected below: *)
listaffine:=Table[
If[
UnsameQ[affine[[i,j,k]],0],
{Subscript[Superscript[Γ,i],j,k],affine[[i,j,k]]}
  ] ,
{i,1,n},{j,1,n},{k,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Christoffel Symbols:"];
Print[TableForm[Partition[DeleteCases[Flatten[listaffine],Null],2],TableSpacing->{2,2}]];
riemann:=riemann=FullSimplify[Table[
(* (Subscript[(R^i), jkl])=    (∂_k)(Subscript[(Γ^i), lj])                   -         (∂_l)(Subscript[(Γ^i), kj])*)
D[       affine[[i,l,j]],  coord[[k]]           ]-D[affine[[i,k,j]], coord[[l]]          ]+
(*         (Subscript[(Γ^i), ks])             (Subscript[(Γ^s), lj])     -         (Subscript[(Γ^i), ls])            (Subscript[(Γ^s), kj])      *)
Sum[affine[[i,k,s]]affine[[s,l,j]] -    affine[[i,l,s]] affine[[s,k,j]] ,
{s,1,n}],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}] ];
listriemann:=Table[
If[
UnsameQ[riemann[[i,j,k,l]],0],
{Subscript[Superscript[R,i],j,k,l],riemann[[i,j,k,l]]}
] ,
{i,1,n},{j,1,n},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listriemann],Null],2],TableSpacing->{2,2}]];
lriemann:=lriemann=FullSimplify[Table[
Sum[metric[[i,ii]] riemann[[ii,j,k,l]],{ii,1,n}],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listlriemann:=Table[
If[
UnsameQ[lriemann[[i,j,k,l]],0],
{Subscript[R,i,j,k,l],lriemann[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Contravariant Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listlriemann],Null],2],TableSpacing->{2,2}]];
uriemann:=uriemann=FullSimplify[Table[
Sum[
inversemetric[[j,jj]] inversemetric[[k,kk]] inversemetric[[l,ll]] riemann[[i,jj,kk,ll]],{jj,1,n},{kk,1,n},{ll,1,n}
],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listuriemann:=Table[
If[
UnsameQ[uriemann[[i,j,k,l]],0],{Superscript[Superscript[Superscript[Superscript[R,i],j],k],l],uriemann[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Covariant Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listuriemann],Null],2],TableSpacing->{2,2}]];
r2=FullSimplify[Sum[lriemann[[i,j,k,l]]uriemann[[i,j,k,l]],{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
Print["-----------------------------------------------------------------------"];
Print["(R^2)= ",r2];
ricci:=ricci=FullSimplify[Table[
Sum[
riemann[[i,j,i,l]],
{i,1,n}
],{j,1,n},{l,1,n}] ];
listricci:=Table[
If[
UnsameQ[ricci[[j,l]],0],
{Subscript[R,j,l],ricci[[j,l]]}
] ,{j,1,n},{l,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Ricci Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listricci],Null],2],TableSpacing->{2,2}]];
scalar=FullSimplify[Sum[inversemetric[[i,j]]ricci[[i,j]],{i,1,n},{j,1,n}] ];
Print["-----------------------------------------------------------------------"];
Print["Curvature Scalar:"];
Print["R= ",scalar];
einstein:=einstein=FullSimplify[ricci-(1/2)scalar*metric];
listeinstein:=Table[
If[
UnsameQ[einstein[[j,l]],0],
{Subscript[G,j,l],einstein[[j,l]]}
] ,{j,1,n},{l,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Einstein Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listeinstein],Null],2],TableSpacing->{2,2}]];
weyl:=weyl=FullSimplify[Table[
If[n>3,
lriemann[[i,j,k,l]]
-         (1/(n-2))           (metric[[i,k]] ricci[[l,j]] -metric[[i,l]] ricci[[k,j]]-metric[[j,k]] ricci[[l,i]]+metric[[j,l]] ricci[[k,i]])
+(1/((n-1)(n-2)))(metric[[i,k]] metric[[l,j]]-metric[[i,l]] metric[[k,j]]) scalar
(*else, if n<= 3 return 0:*),0],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listweyl:=Table[
If[
UnsameQ[weyl[[i,j,k,l]],0],
{Subscript[ℭ,i,j,k,l],weyl[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Weyl Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listweyl],Null],2],TableSpacing->{2,2}]];
geodesic:=geodesic=Simplify[Table[-Sum[affine[[i,j,k]]u[j]u[k],{j,1,n},{k,1,n}],{i,1,n}]];
subst = Table[u[i]-> Subscript[coord[[i]],τ],{i,1,n}];
nlistgeodesic:=Table[{Subscript[coord[[i]],ττ],"+",-geodesic[[i]]/.subst,"= 0"},{i,1,n}];
Print["-----------------------------------------------------------------------"];
Print["Geodesic Equations:"];
Print[TableForm[nlistgeodesic,TableSpacing->{2}]];

Problem 6, Carroll

Clear[coord, metric,inversemetric, affine, riemann, lriemann, uriemann, ricci, scalar, einstein,weyl, geodesic,R,G,τ, i,j,k,l,s];
Clear[r,θ,ϕ,t,χ,a,m,x,y,ψ]; 

(*----------------------------------------------------------------------------*)
(* This is what you need to set: *)
coord = {t,r,θ,ϕ};
n          =Length[coord];
metric={
{-(1-((2M)/r)) ,0            ,  0    , 0                   },
{0                   ,1+((2M)/r) ,   0   ,0                    },
{0                   , 0           ,(r^2)    , 0                   },
{0                   , 0           , 0     , (r^2) ((Sin[θ])^2)}};
(*----------------------------------------------------------------------------*)

inversemetric=FullSimplify[Inverse[metric]];
Print["-----------------------------------------------------------------------"];
Print["The Manifold has dimension   n= ",n,"\nCoordinate system:          ",coord];
Print["-----------------------------------------------------------------------"];
Print["(Subscript[g, μν])=",metric//MatrixForm];
Print["(g^(μν))=",inversemetric//MatrixForm];
Print["g  =",Det[metric]//FullSimplify];
affine:=affine=FullSimplify[Table[
(1/2)*Sum[
(*              (g^is) ((∂_k)(Subscript[g, sj])+(∂_j)(Subscript[g, sk])-(∂_s)(Subscript[g, jk]))           *)
(inversemetric[[i,s]])*
(D[metric[[s,j]],coord[[k]] ]+D[metric[[s,k]],coord[[j]] ]-D[metric[[j,k]],coord[[s]] ]),
{s,1,n}],
{i,1,n},{j,1,n},{k,1,n}] ];
(*The non zero Christoffel symbols are computed and selected below: *)
listaffine:=Table[
If[
UnsameQ[affine[[i,j,k]],0],
{Subscript[Superscript[Γ,i],j,k],affine[[i,j,k]]}
  ] ,
{i,1,n},{j,1,n},{k,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Christoffel Symbols:"];
Print[TableForm[Partition[DeleteCases[Flatten[listaffine],Null],2],TableSpacing->{2,2}]];
riemann:=riemann=FullSimplify[Table[
(* (Subscript[(R^i), jkl])=    (∂_k)(Subscript[(Γ^i), lj])                   -         (∂_l)(Subscript[(Γ^i), kj])*)
D[       affine[[i,l,j]],  coord[[k]]           ]-D[affine[[i,k,j]], coord[[l]]          ]+
(*         (Subscript[(Γ^i), ks])             (Subscript[(Γ^s), lj])     -         (Subscript[(Γ^i), ls])            (Subscript[(Γ^s), kj])      *)
Sum[affine[[i,k,s]]affine[[s,l,j]] -    affine[[i,l,s]] affine[[s,k,j]] ,
{s,1,n}],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}] ];
listriemann:=Table[
If[
UnsameQ[riemann[[i,j,k,l]],0],
{Subscript[Superscript[R,i],j,k,l],riemann[[i,j,k,l]]}
] ,
{i,1,n},{j,1,n},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listriemann],Null],2],TableSpacing->{2,2}]];
lriemann:=lriemann=FullSimplify[Table[
Sum[metric[[i,ii]] riemann[[ii,j,k,l]],{ii,1,n}],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listlriemann:=Table[
If[
UnsameQ[lriemann[[i,j,k,l]],0],
{Subscript[R,i,j,k,l],lriemann[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Contravariant Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listlriemann],Null],2],TableSpacing->{2,2}]];
uriemann:=uriemann=FullSimplify[Table[
Sum[
inversemetric[[j,jj]] inversemetric[[k,kk]] inversemetric[[l,ll]] riemann[[i,jj,kk,ll]],{jj,1,n},{kk,1,n},{ll,1,n}
],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listuriemann:=Table[
If[
UnsameQ[uriemann[[i,j,k,l]],0],{Superscript[Superscript[Superscript[Superscript[R,i],j],k],l],uriemann[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Covariant Riemann Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listuriemann],Null],2],TableSpacing->{2,2}]];
r2=FullSimplify[Sum[lriemann[[i,j,k,l]]uriemann[[i,j,k,l]],{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
Print["-----------------------------------------------------------------------"];
Print["(R^2)= ",r2];
ricci:=ricci=FullSimplify[Table[
Sum[
riemann[[i,j,i,l]],
{i,1,n}
],{j,1,n},{l,1,n}] ];
listricci:=Table[
If[
UnsameQ[ricci[[j,l]],0],
{Subscript[R,j,l],ricci[[j,l]]}
] ,{j,1,n},{l,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Ricci Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listricci],Null],2],TableSpacing->{2,2}]];
scalar=FullSimplify[Sum[inversemetric[[i,j]]ricci[[i,j]],{i,1,n},{j,1,n}] ];
Print["-----------------------------------------------------------------------"];
Print["Curvature Scalar:"];
Print["R= ",scalar];
einstein:=einstein=FullSimplify[ricci-(1/2)scalar*metric];
listeinstein:=Table[
If[
UnsameQ[einstein[[j,l]],0],
{Subscript[G,j,l],einstein[[j,l]]}
] ,{j,1,n},{l,1,j}];
Print["-----------------------------------------------------------------------"];
Print["Einstein Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listeinstein],Null],2],TableSpacing->{2,2}]];
weyl:=weyl=FullSimplify[Table[
If[n>3,
lriemann[[i,j,k,l]]
-         (1/(n-2))           (metric[[i,k]] ricci[[l,j]] -metric[[i,l]] ricci[[k,j]]-metric[[j,k]] ricci[[l,i]]+metric[[j,l]] ricci[[k,i]])
+(1/((n-1)(n-2)))(metric[[i,k]] metric[[l,j]]-metric[[i,l]] metric[[k,j]]) scalar
(*else, if n<= 3 return 0:*),0],
{i,1,n},{j,1,n},{k,1,n},{l,1,n}]];
listweyl:=Table[
If[
UnsameQ[weyl[[i,j,k,l]],0],
{Subscript[ℭ,i,j,k,l],weyl[[i,j,k,l]]}
] ,{i,1,n},{j,1,i-1},{k,1,n},{l,1,k-1}];
Print["-----------------------------------------------------------------------"];
Print["Weyl Tensor:"];
Print[TableForm[Partition[DeleteCases[Flatten[listweyl],Null],2],TableSpacing->{2,2}]];
geodesic:=geodesic=Simplify[Table[-Sum[affine[[i,j,k]]u[j]u[k],{j,1,n},{k,1,n}],{i,1,n}]];
subst = Table[u[i]-> Subscript[coord[[i]],τ],{i,1,n}];
nlistgeodesic:=Table[{Subscript[coord[[i]],ττ],"+",-geodesic[[i]]/.subst,"= 0"},{i,1,n}];
Print["-----------------------------------------------------------------------"];
Print["Geodesic Equations:"];
Print[TableForm[nlistgeodesic,TableSpacing->{2}]];