​
A Mathematica notebook to verify the solution in Hoang K. Nguyen’s paper “A new vacuo solution inspired by Buchdahl for pure R2 gravity”
Richard Shurtleff
​
Abstract
This notebook verifies the solution and many of the equations displayed in the discussion of the solution as presented in Hoang K. Nguyen’s paper “A new family of metrics inspired by Buchdahl for pure
2
R
gravity”, dated March 31, 2022. In this notebook, the equation numbers and references to pages of text refer to that paper.
​
URL for this Mathematica notebook:
https://www.wolframcloud.com/obj/shurtleffr/Published/20220401QuadraticGravityBuchdahl1.nb
https://www.dropbox.com/s/r7ccr4nfv12w3wh/20220401QuadraticGravityBuchdahl3.nb?dl=0
​
In[]:=
(*coordinates*)​​x={r,θ,ϕ,t};(*rradialdistance,θpolarangle,ϕazimuthal,ttime*)​​Print["The coordinates
i
x
= ",x,", for i = 1,2,3,4."]​​Print["Note that time is the fourth coordinate,
4
x
= t."]
The coordinates
i
x
= {r,θ,ϕ,t}, for i = 1,2,3,4.
Note that time is the fourth coordinate,
4
x
= t.
In[]:=
(*Metricgis
g
μν
lowerindices;guis
μν
g
upperindices;​​coordinates
i
x
=(r,θ,ϕ,t)with
4
x
=t.*)​​(*Eq.(15)lineelement*)​​(*
2
ds
=-
ν

2
dt
+
λ

2
dr
+
μ

(
2
dθ
+
2
sin
2
θdϕ
)*)​​Table[{g[μ_,ν_,r_,θ_,ϕ_]:=0,gu[μ_,ν_,r_,θ_,ϕ_]:=0},{μ,4},{ν,4}];​​Table[{g[μ,ν,r,θ,ϕ],gu[μ,ν,r,θ,ϕ]},{μ,4},{ν,4}];​​g[4,4,r_,θ_,ϕ_]:=-Exp[nU[r]]​​g[1,1,r_,θ_,ϕ_]:=Exp[lAmbda[r]]​​g[2,2,r_,θ_,ϕ_]:=Exp[mU[r]]​​g[3,3,r_,θ_,ϕ_]:=Exp[mU[r]]
2
Sin[θ]
​​gu[4,4,r_,θ_,ϕ_]:=-Exp[-nU[r]]​​gu[1,1,r_,θ_,ϕ_]:=Exp[-lAmbda[r]]​​gu[2,2,r_,θ_,ϕ_]:=Exp[-mU[r]]​​gu[3,3,r_,θ_,ϕ_]:=Exp[-mU[r]]
-2
Sin[θ]
In[]:=
(*m-matrix*)​​gm[r_,θ_,ϕ_]:=Table[g[μ,ν,r,θ,ϕ],{μ,4},{ν,4}]​​gum[r_,θ_,ϕ_]:=Table[gu[μ,ν,r,θ,ϕ],{μ,4},{ν,4}]
In[]:=
Print["metric
g
μν
= ",gm[r,θ,ϕ]//MatrixForm];​​Print"check:
g
ασ
σβ
g
=
β
δ
α
?=? ",gm[r,θ,ϕ].gum[r,θ,ϕ]//MatrixForm
metric
g
μν
=
lAmbda[r]

0
0
0
0
mU[r]

0
0
0
0
mU[r]

2
Sin[θ]
0
0
0
0
-
nU[r]

check:
g
ασ
σβ
g
=
β
δ
α
?=?
1
0
0
0
0
1
0
0
0
0
1
0
0
0
0
1
In[]:=
(*Eq.(15)lineelement*)​​(*
2
ds
=-
ν

2
dt
+
λ

2
dr
+
μ

(
2
dθ
+
2
sin
2
θdϕ
)*)Print["
2
ds
= ",Sum[g[μ,ν,r,θ,ϕ]{dr,dθ,dϕ,dt}[[μ]]{dr,dθ,dϕ,dt}[[ν]],{μ,4},{ν,4}]]
2
ds
=
2
dr
lAmbda[r]

+
2
dθ
mU[r]

-
2
dt
nU[r]

+
2
dϕ
mU[r]

2
Sin[θ]
In[]:=
​​(*Warm-upexercise,
∂
∂r
g
tt
*)Print"
∂
∂r
g
tt
= ",D[g[4,4,r,θ,ϕ],x[[1]]]
∂
∂r
g
tt
= -
nU[r]

′
nU
[r]
In[]:=
(*cΓChristoffelsymbols*)​​cΓ[α_,μ_,ν_,r_,θ_,ϕ_]:=Sum
1
2
gu[α,β,r,θ,ϕ](D[g[ν,β,r,θ,ϕ],x[[μ]]]+D[g[μ,β,r,θ,ϕ],x[[ν]]]-D[g[μ,ν,r,θ,ϕ],x[[β]]]),{β,4}​​Print"For example,
θ
Γ
rθ
=
2
Γ
12
= ",cΓ[2,1,2,r,θ,ϕ]," and
1
Γ
11
=
r
Γ
rr
= ",cΓ[1,1,1,r,θ,ϕ];
For example,
θ
Γ
rθ
=
2
Γ
12
=
′
mU
[r]
2
and
1
Γ
11
=
r
Γ
rr
=
′
lAmbda
[r]
2
In[]:=
(*tableOFΓhasallcomponentsofΓ*)​​(*tableOFnonzeroΓhasallnonzerocomponentsofΓ*)​​tableOFΓ=Partition[Flatten[Table[{a1,b,c,cΓ[a1,b,c,r,θ,ϕ]},{a1,4},{b,4},{c,4}]],4];​​tableOFnonzeroΓ={};​​For[i=1,i<=Length[tableOFΓ],i++,If[NumericQ[tableOFΓ[[i,4]]]==False,AppendTo[tableOFnonzeroΓ,tableOFΓ[[i]]]]]​​Print" Table of non-zero components
α
Γ
μν
Key: α,μ,ν,​
α
Γ
μν
​"​​tableOFnonzeroΓ
Table of non-zero components
α
Γ
μν
Key: α,μ,ν,​
α
Γ
μν
​
Out[]=
1,1,1,
′
lAmbda
[r]
2
,1,2,2,-
1
2
-lAmbda[r]+mU[r]

′
mU
[r],1,3,3,-
1
2
-lAmbda[r]+mU[r]

2
Sin[θ]
′
mU
[r],1,4,4,
1
2
-lAmbda[r]+nU[r]

′
nU
[r],2,1,2,
′
mU
[r]
2
,2,2,1,
′
mU
[r]
2
,{2,3,3,-Cos[θ]Sin[θ]},3,1,3,
′
mU
[r]
2
,{3,2,3,Cot[θ]},3,3,1,
′
mU
[r]
2
,{3,3,2,Cot[θ]},4,1,4,
′
nU
[r]
2
,4,4,1,
′
nU
[r]
2

In[]:=
(*Eq.(20),
r
Γ
tt
=
1
Γ
44
=ν'/2*)​​cΓ[1,4,4,r,θ,ϕ]Exp[lAmbda[r]-nU[r]]​​
Out[]=
′
nU
[r]
2
In[]:=
(*Eq.(21),
r
Γ
θθ
=
1
Γ
22
=-μ'/2*)​​cΓ[1,2,2,r,θ,ϕ]Exp[lAmbda[r]-mU[r]]​​
Out[]=
-
1
2
′
mU
[r]
In[]:=
(*Eq.(22),
r
Γ
rr
=
1
Γ
11
=λ'/2*)​​cΓ[1,1,1,r,θ,ϕ]​​
Out[]=
′
lAmbda
[r]
2
In[]:=
(*WeinbergGrav&Cosmop.133(6.1.5)
λ
cRC
μνκ
=Riemann-Christofelcurvaturetensor*)​​cRC[λ_,μ_,ν_,κ_,r_,θ_,ϕ_]:=D[cΓ[λ,μ,ν,r,θ,ϕ],x[[κ]]]-D[cΓ[λ,μ,κ,r,θ,ϕ],x[[ν]]]+Sum[cΓ[s,μ,ν,r,θ,ϕ]cΓ[λ,κ,s,r,θ,ϕ]-cΓ[s,μ,κ,r,θ,ϕ]cΓ[λ,ν,s,r,θ,ϕ],{s,4}]​​Print"For example,
r
R
θrθ
=
1
R
212
= ",Simplify[cRC[1,2,1,2,r,θ,ϕ]];
For example,
r
R
θrθ
=
1
R
212
=
1
4
-lAmbda[r]+mU[r]

(-
′
lAmbda
[r]
′
mU
[r]+
2
′
mU
[r]
+2
′′
mU
[r])
In[]:=
(*cR=Riccitensor
R
αβ
=
σ
cR
αβσ
,wherewefollowNguyenandDodelsonp.32.OppositesignfromWeinbergp.135(6.2.5)
R
αβW
=
σ
cR
ασβ
,notelowerσ.*)​​cR[α_,β_,r_,θ_,ϕ_]:=Simplify[Sum[cRC[σ,α,β,σ,r,θ,ϕ],{σ,4}]]​​Print["For example,
R
tt
=
R
44
= ",cR[4,4,r,θ,ϕ]," and
R
rr
= ",Simplify[cR[1,1,r,θ,ϕ]]];
For example,
R
tt
=
R
44
=
1
4
-lAmbda[r]+nU[r]

(-
′
lAmbda
[r]
′
nU
[r]+2
′
mU
[r]
′
nU
[r]+
2
′
nU
[r]
+2
′′
nU
[r]) and
R
rr
=
1
4
(-2
2
′
mU
[r]
-
2
′
nU
[r]
+
′
lAmbda
[r](2
′
mU
[r]+
′
nU
[r])-4
′′
mU
[r]-2
′′
nU
[r])
In[]:=
(*tableOFRμνhasallcomponentsof
R
μν
*)​​(*tableOFnonzeroRμνhasallnonzerocomponentsof
R
μν
*)​​tableOFRμν=Partition[Flatten[Table[{a1,b,cR[a1,b,r,θ,ϕ]},{a1,4},{b,4}]],3];​​tableOFnonzeroRμν={};​​For[i=1,i<=Length[tableOFRμν],i++,If[NumericQ[tableOFRμν[[i,3]]]==False,AppendTo[tableOFnonzeroRμν,tableOFRμν[[i]]]]]​​Print[" Table of non-zero components
R
μν
Key: {μ,ν,​
R
μν
​}"]​​tableOFnonzeroRμν
Table of non-zero components
R
μν
Key: {μ,ν,​
R
μν
​}
Out[]=
1,1,
1
4
(-2
2
′
mU
[r]
-
2
′
nU
[r]
+
′
lAmbda
[r](2
′
mU
[r]+
′
nU
[r])-4
′′
mU
[r]-2
′′
nU
[r]),2,2,
1
4
-lAmbda[r]

4
lAmbda[r]

+
mU[r]

′
lAmbda
[r]
′
mU
[r]-2
mU[r]

2
′
mU
[r]
-
mU[r]

′
mU
[r]
′
nU
[r]-2
mU[r]

′′
mU
[r],3,3,
1
4
-lAmbda[r]

2
Sin[θ]
4
lAmbda[r]

+
mU[r]

′
lAmbda
[r]
′
mU
[r]-2
mU[r]

2
′
mU
[r]
-
mU[r]

′
mU
[r]
′
nU
[r]-2
mU[r]

′′
mU
[r],4,4,
1
4
-lAmbda[r]+nU[r]

(-
′
lAmbda
[r]
′
nU
[r]+2
′
mU
[r]
′
nU
[r]+
2
′
nU
[r]
+2
′′
nU
[r])
In[]:=
(*Eq.(23),
R
tt
λ-ν

=
ν''
2
+
2
(ν')
4
-
ν'λ'
4
+
ν'μ'
2
*)​​Expand[cR[4,4,r,θ,ϕ]Exp[lAmbda[r]-nU[r]]]
Out[]=
-
1
4
′
lAmbda
[r]
′
nU
[r]+
1
2
′
mU
[r]
′
nU
[r]+
1
4
2
′
nU
[r]
+
′′
nU
[r]
2
In[]:=
(*Eq.(24),-
R
θθ
λ-μ

=-
λ-μ

+
μ''
2
+
2
(μ')
2
+
ν'μ'
4
-
λ'μ'
4
*)​​Expand[-cR[2,2,r,θ,ϕ]Exp[lAmbda[r]-mU[r]]]
Out[]=
-
lAmbda[r]-mU[r]

-
1
4
′
lAmbda
[r]
′
mU
[r]+
1
2
2
′
mU
[r]
+
1
4
′
mU
[r]
′
nU
[r]+
′′
mU
[r]
2
In[]:=
(*Eq.(25),-
R
rr
=+
ν''
2
+
2
(ν')
4
+μ''+
2
(μ')
2
-
ν'λ'
4
-
λ'μ'
2
*)​​Expand[-cR[1,1,r,θ,ϕ]]
Out[]=
-
1
2
′
lAmbda
[r]
′
mU
[r]+
1
2
2
′
mU
[r]
-
1
4
′
lAmbda
[r]
′
nU
[r]+
1
4
2
′
nU
[r]
+
′′
mU
[r]+
′′
nU
[r]
2
From text on page 3, second column: “Finally, we substitute {p’,q’;p’’,q’’;...} in (40-47) into {ν’,λ’,μ’; ν’’,λ’’,μ’’;...} in (29-39)”
Once the formulas from (40-47) are substituted in (29-39), the new versions of (29-39) will be distinguished by the letter “A”. Thus, for ν’(r) = nup[r], the new version is ν’(r) = nupA[r].
From the text page 3, second column, “...Maxima Online determines that the left-hand-sides of Eqs. (12), (13), (14) vanish identically. In addition, it confirms that R(r) = ± f(r) (48)”
The substitutions indicated in the text can be carried out.
​
Thus we confirm the assertions that “the left-hand-sides of Eqs. (12), (13), (14) vanish identically. In addition, it confirms that R(r) = ± f(r) (48)”
​
​
https://www.wolframcloud.com/obj/shurtleffr/Published/20220401QuadraticGravityBuchdahl1.nb
https://www.dropbox.com/s/r7ccr4nfv12w3wh/20220401QuadraticGravityBuchdahl3.nb?dl=0
​