Clear[coord,metric,inversemetric,chrissym,riemann,riemannfirstk,conriemannfirstk,kretschmann]

Kretschmann Scalar

Set Up

n=4

coord={t,r,θ,ϕ}

Schwarzschild Geometry

metric={{-(1-((2G*M)/((c^2)r))),0,0,0},{0,(((1-((2G*M)/((c^2)r))))^(-1)),0,0},{0,0,(r^2),0},{0,0,0,(r^2)((Sin[θ])^2)}}

metric//MatrixForm

inversemetric=Simplify[Inverse[metric]]

inversemetric//MatrixForm

Christoffel Symbols

(Subscript[(Γ^σ), μν])=(1/2)(g^(σα))((∂_μ)(Subscript[g, αν])+(∂_ν)(Subscript[g, αμ])-(∂_α)(Subscript[g, μν]) )

chrissym:=chrissym=Simplify[Table[(1/2)Sum[(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}]]

listchrissym:=Table[If[UnsameQ[chrissym[[i,j,k]],0],{ToString[Γ[i,j,k]],chrissym[[i,j,k]]}],{i,1,n},{j,1,n},{k,1,n}]

Non-zero Christoffel Symbols Components

TableForm[Partition[DeleteCases[Flatten[listchrissym],Null],2],TableSpacing->{2,2}]

listchrissym//MatrixForm

Riemann Tensor (2nd kind)

(Subscript[(R^α), βγδ])=(∂_γ)(Subscript[(Γ^α), βδ])-(∂_δ)(Subscript[(Γ^α), βγ])+(Subscript[(Γ^μ), βδ])(Subscript[(Γ^α), μγ])-(Subscript[(Γ^μ), βγ])(Subscript[(Γ^α), μδ]) )

riemann:=riemann=Simplify[Table[D[chrissym[[i,j,l]],coord[[k]]]-D[chrissym[[i,j,k]],coord[[l]]]+Sum[chrissym[[s,j,l]]*chrissym[[i,k,s]]-chrissym[[s,j,k]]*chrissym[[i,l,s]],{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],{ToString[R2[i,j,k,l]],riemann[[i,j,k,l]]}],{i,1,n},{j,1,n},{k,1,n},{l,1,n}]

Non-zero Riemann Tensor Components

TableForm[Partition[DeleteCases[Flatten[listriemann],Null],2],TableSpacing->{2, 2}]

listriemann//MatrixForm

Riemann Tensor (1st kind)

(Subscript[R, αβγδ])=(Subscript[g, ασ])(Subscript[(R^σ), βγδ])

riemannfirstk:=riemannfirstk=Simplify[Table[Sum[metric[[s,i]]*riemann[[i,j,k,l]],{i,1,4}],{s,1,n},{j,1,n},{k,1,n},{l,1,n}]]

listriemannfirstk:=Table[If[UnsameQ[riemannfirstk[[i,j,k,l]],0],{ToString[R1[i,j,k,l]],riemannfirstk[[i,j,k,l]]}],{i,1,n},{j,1,n},{k,1,n},{l,1,n}]

Non-zero Riemann Tensor Components

TableForm[Partition[DeleteCases[Flatten[listriemannfirstk],Null],2],TableSpacing->{2, 2}]

listriemannfirstk//MatrixForm

Contravariant Riemann Tensor (1st kind)

(R^(αβγδ))=(g^(σβ))(g^(θγ))(g^(μδ))(Subscript[(R^α), σθμ])

conriemannfirstk:=conriemannfirstk=Simplify[Table[Sum[inversemetric[[j,s]]*inversemetric[[k,t]]*inversemetric[[l,u]]*riemann[[i,j,k,l]],{s,1,4},{t,1,4},{u,1,4}],{i,1,n},{j,1,n},{k,1,n},{l,1,n}]]

listconriemannfirstk:=Table[If[UnsameQ[conriemannfirstk[[i,j,k,l]],0],{ToString[Rcon[i,j,k,l]],conriemannfirstk[[i,j,k,l]]}],{i,1,n},{j,1,n},{k,1,n},{l,1,n}]

Non-zero Contravariant Riemann Tensor Components

TableForm[Partition[DeleteCases[Flatten[listconriemannfirstk],Null],2],TableSpacing->{2, 2}]

listconriemannfirstk//MatrixForm

Kretschmann Scalar

k=(R^(αβγδ))(Subscript[R, αβγδ])

kretschmann=Simplify[Sum[conriemannfirstk[[i,j,k,l]]*riemannfirstk[[i,j,k,l]],{i,1,4},{j,1,4},{k,1,4},{l,1,4}]]

Adaptation author: Alexander Sarango

I adapted this code from the notebook “Curvature and the Einstein Equation” which was written by Leonard Parker. You can find it here on James B. Hartle’s “Gravity” book website: https://www.physics.ucsb.edu/~gravitybook/mathematica.html