[TEST]UPSTREAM: Pick some source changes from 48080d0a97
* Sync new folder structure
This commit is contained in:
382
AMSS_NCKU_source/BSSN/adm_constraint.f90
Normal file
382
AMSS_NCKU_source/BSSN/adm_constraint.f90
Normal file
@@ -0,0 +1,382 @@
|
||||
|
||||
!-------------------------------------------------------------------------------!
|
||||
! computed constraint for ADM formalism !
|
||||
!-------------------------------------------------------------------------------!
|
||||
subroutine constraint_adm(ex, X, Y, Z,&
|
||||
dxx,gxy,gxz,dyy,gyz,dzz, &
|
||||
Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, &
|
||||
Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,&
|
||||
ham_Res, movx_Res, movy_Res, movz_Res, &
|
||||
Symmetry)
|
||||
|
||||
implicit none
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer,intent(in ):: ex(1:3),symmetry
|
||||
real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3))
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res
|
||||
!~~~~~~> Other variables:
|
||||
! inverse metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz
|
||||
! first order derivative of metric, @_k g_ij
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,trK,fx,fy,fz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxxx, Gamxxy, Gamxxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxyy, Gamxyz, Gamxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyxx, Gamyxy, Gamyxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyyy, Gamyyz, Gamyzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzxx, Gamzxy, Gamzxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzyy, Gamzyz, Gamzzz
|
||||
|
||||
integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2
|
||||
real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0
|
||||
real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0
|
||||
real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0
|
||||
real*8 :: PI
|
||||
|
||||
call adm_ricci_gamma(ex, X, Y, Z, &
|
||||
dxx , gxy , gxz , dyy , gyz , dzz,&
|
||||
Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,&
|
||||
Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,&
|
||||
Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,&
|
||||
Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,&
|
||||
Symmetry)
|
||||
|
||||
PI = dacos(-ONE)
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
! invert metric
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
trK = gupxx * Kxx + gupyy * Kyy + gupzz * Kzz &
|
||||
+ TWO * (gupxy * Kxy + gupxz * Kxz + gupyz * Kyz)
|
||||
|
||||
! ham_Res = trR + K^2 - K_ij * K^ij - 16 * PI * rho
|
||||
ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + &
|
||||
TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz )
|
||||
|
||||
ham_Res = ham_Res + trK * trK -(&
|
||||
gupxx * ( &
|
||||
gupxx * Kxx * Kxx + gupyy * Kxy * Kxy + gupzz * Kxz * Kxz + &
|
||||
TWO * (gupxy * Kxx * Kxy + gupxz * Kxx * Kxz + gupyz * Kxy * Kxz) ) + &
|
||||
gupyy * ( &
|
||||
gupxx * Kxy * Kxy + gupyy * Kyy * Kyy + gupzz * Kyz * Kyz + &
|
||||
TWO * (gupxy * Kxy * Kyy + gupxz * Kxy * Kyz + gupyz * Kyy * Kyz) ) + &
|
||||
gupzz * ( &
|
||||
gupxx * Kxz * Kxz + gupyy * Kyz * Kyz + gupzz * Kzz * Kzz + &
|
||||
TWO * (gupxy * Kxz * Kyz + gupxz * Kxz * Kzz + gupyz * Kyz * Kzz) ) + &
|
||||
TWO * ( &
|
||||
gupxy * ( &
|
||||
gupxx * Kxx * Kxy + gupyy * Kxy * Kyy + gupzz * Kxz * Kyz + &
|
||||
gupxy * (Kxx * Kyy + Kxy * Kxy) + &
|
||||
gupxz * (Kxx * Kyz + Kxz * Kxy) + &
|
||||
gupyz * (Kxy * Kyz + Kxz * Kyy) ) + &
|
||||
gupxz * ( &
|
||||
gupxx * Kxx * Kxz + gupyy * Kxy * Kyz + gupzz * Kxz * Kzz + &
|
||||
gupxy * (Kxx * Kyz + Kxy * Kxz) + &
|
||||
gupxz * (Kxx * Kzz + Kxz * Kxz) + &
|
||||
gupyz * (Kxy * Kzz + Kxz * Kyz) ) + &
|
||||
gupyz * ( &
|
||||
gupxx * Kxy * Kxz + gupyy * Kyy * Kyz + gupzz * Kyz * Kzz + &
|
||||
gupxy * (Kxy * Kyz + Kyy * Kxz) + &
|
||||
gupxz * (Kxy * Kzz + Kyz * Kxz) + &
|
||||
gupyz * (Kyy * Kzz + Kyz * Kyz) ) ))- F16 * PI * rho
|
||||
|
||||
! mov_Res_j = gupkj*D_k K_ij - d_j trK - 8 PI s_j where D respect to physical metric
|
||||
! store D_i K_jk
|
||||
call fderivs(ex,Kxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
call fderivs(ex,Kxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0)
|
||||
call fderivs(ex,Kxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0)
|
||||
call fderivs(ex,Kyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
call fderivs(ex,Kyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0)
|
||||
call fderivs(ex,Kzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
|
||||
gxxx = gxxx - ( Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz &
|
||||
+ Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz)
|
||||
gxyx = gxyx - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz &
|
||||
+ Gamxxx * Kxy + Gamyxx * Kyy + Gamzxx * Kyz)
|
||||
gxzx = gxzx - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz &
|
||||
+ Gamxxx * Kxz + Gamyxx * Kyz + Gamzxx * Kzz)
|
||||
gyyx = gyyx - ( Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz &
|
||||
+ Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz)
|
||||
gyzx = gyzx - ( Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz &
|
||||
+ Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz)
|
||||
gzzx = gzzx - ( Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz &
|
||||
+ Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz)
|
||||
gxxy = gxxy - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz &
|
||||
+ Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz)
|
||||
gxyy = gxyy - ( Gamxyy * Kxx + Gamyyy * Kxy + Gamzyy * Kxz &
|
||||
+ Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz)
|
||||
gxzy = gxzy - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz &
|
||||
+ Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz)
|
||||
gyyy = gyyy - ( Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz &
|
||||
+ Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz)
|
||||
gyzy = gyzy - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz &
|
||||
+ Gamxyy * Kxz + Gamyyy * Kyz + Gamzyy * Kzz)
|
||||
gzzy = gzzy - ( Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz &
|
||||
+ Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz)
|
||||
gxxz = gxxz - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz &
|
||||
+ Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz)
|
||||
gxyz = gxyz - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz &
|
||||
+ Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz)
|
||||
gxzz = gxzz - ( Gamxzz * Kxx + Gamyzz * Kxy + Gamzzz * Kxz &
|
||||
+ Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz)
|
||||
gyyz = gyyz - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz &
|
||||
+ Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz)
|
||||
gyzz = gyzz - ( Gamxzz * Kxy + Gamyzz * Kyy + Gamzzz * Kyz &
|
||||
+ Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz)
|
||||
gzzz = gzzz - ( Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz &
|
||||
+ Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz)
|
||||
movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz &
|
||||
+gupxy*gxyx + gupxz*gxzx + gupyz*gxzy &
|
||||
+gupxy*gxxy + gupxz*gxxz + gupyz*gxyz
|
||||
movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz &
|
||||
+gupxy*gyyx + gupxz*gyzx + gupyz*gyzy &
|
||||
+gupxy*gxyy + gupxz*gxyz + gupyz*gyyz
|
||||
movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz &
|
||||
+gupxy*gyzx + gupxz*gzzx + gupyz*gzzy &
|
||||
+gupxy*gxzy + gupxz*gxzz + gupyz*gyzz
|
||||
|
||||
call fderivs(ex,trK,fx,fy,fz,X,Y,Z,SYM,SYM,SYM,Symmetry,0)
|
||||
|
||||
movx_Res = movx_Res - fx - F8*PI*sx
|
||||
movy_Res = movy_Res - fy - F8*PI*sy
|
||||
movz_Res = movz_Res - fz - F8*PI*sz
|
||||
|
||||
return
|
||||
|
||||
end subroutine constraint_adm
|
||||
!-------------------------------------------------------------------------------!
|
||||
! computed constraint for ADM formalism for shell !
|
||||
!-------------------------------------------------------------------------------!
|
||||
subroutine constraint_adm_ss(ex,crho,sigma,R, X, Y, Z,&
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz, &
|
||||
drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, &
|
||||
dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, &
|
||||
dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, &
|
||||
dxx,gxy,gxz,dyy,gyz,dzz, &
|
||||
Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, &
|
||||
Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,&
|
||||
Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, &
|
||||
Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, &
|
||||
Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, &
|
||||
Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, &
|
||||
ham_Res, movx_Res, movy_Res, movz_Res, &
|
||||
Symmetry,Lev,sst)
|
||||
|
||||
implicit none
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer,intent(in ):: ex(1:3),symmetry,Lev,sst
|
||||
double precision,intent(in),dimension(ex(1))::crho
|
||||
double precision,intent(in),dimension(ex(2))::sigma
|
||||
double precision,intent(in),dimension(ex(3))::R
|
||||
real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz
|
||||
! second kind of Christofel symble Gamma^i_jk respect to physical metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res
|
||||
!~~~~~~> Other variables:
|
||||
! inverse metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz
|
||||
! first order derivative of metric, @_k g_ij
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,trK,fx,fy,fz
|
||||
|
||||
integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2
|
||||
real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0
|
||||
real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0
|
||||
real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0
|
||||
real*8 :: PI
|
||||
|
||||
call adm_ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz, &
|
||||
drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, &
|
||||
dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, &
|
||||
dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, &
|
||||
dxx , gxy , gxz , dyy , gyz , dzz,&
|
||||
Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,&
|
||||
Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,&
|
||||
Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,&
|
||||
Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,&
|
||||
Symmetry,Lev,sst)
|
||||
|
||||
PI = dacos(-ONE)
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
! invert metric
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
trK = gupxx * Kxx + gupyy * Kyy + gupzz * Kzz &
|
||||
+ TWO * (gupxy * Kxy + gupxz * Kxz + gupyz * Kyz)
|
||||
|
||||
! ham_Res = trR + K^2 - K_ij * K^ij - 16 * PI * rho
|
||||
ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + &
|
||||
TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz )
|
||||
|
||||
ham_Res = ham_Res + trK * trK -(&
|
||||
gupxx * ( &
|
||||
gupxx * Kxx * Kxx + gupyy * Kxy * Kxy + gupzz * Kxz * Kxz + &
|
||||
TWO * (gupxy * Kxx * Kxy + gupxz * Kxx * Kxz + gupyz * Kxy * Kxz) ) + &
|
||||
gupyy * ( &
|
||||
gupxx * Kxy * Kxy + gupyy * Kyy * Kyy + gupzz * Kyz * Kyz + &
|
||||
TWO * (gupxy * Kxy * Kyy + gupxz * Kxy * Kyz + gupyz * Kyy * Kyz) ) + &
|
||||
gupzz * ( &
|
||||
gupxx * Kxz * Kxz + gupyy * Kyz * Kyz + gupzz * Kzz * Kzz + &
|
||||
TWO * (gupxy * Kxz * Kyz + gupxz * Kxz * Kzz + gupyz * Kyz * Kzz) ) + &
|
||||
TWO * ( &
|
||||
gupxy * ( &
|
||||
gupxx * Kxx * Kxy + gupyy * Kxy * Kyy + gupzz * Kxz * Kyz + &
|
||||
gupxy * (Kxx * Kyy + Kxy * Kxy) + &
|
||||
gupxz * (Kxx * Kyz + Kxz * Kxy) + &
|
||||
gupyz * (Kxy * Kyz + Kxz * Kyy) ) + &
|
||||
gupxz * ( &
|
||||
gupxx * Kxx * Kxz + gupyy * Kxy * Kyz + gupzz * Kxz * Kzz + &
|
||||
gupxy * (Kxx * Kyz + Kxy * Kxz) + &
|
||||
gupxz * (Kxx * Kzz + Kxz * Kxz) + &
|
||||
gupyz * (Kxy * Kzz + Kxz * Kyz) ) + &
|
||||
gupyz * ( &
|
||||
gupxx * Kxy * Kxz + gupyy * Kyy * Kyz + gupzz * Kyz * Kzz + &
|
||||
gupxy * (Kxy * Kyz + Kyy * Kxz) + &
|
||||
gupxz * (Kxy * Kzz + Kyz * Kxz) + &
|
||||
gupyz * (Kyy * Kzz + Kyz * Kyz) ) ))- F16 * PI * rho
|
||||
|
||||
! mov_Res_j = gupkj*D_k K_ij - d_j trK - 8 PI s_j where D respect to physical metric
|
||||
! store D_i K_jk
|
||||
call fderivs_shc(ex,Kxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Kxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Kxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Kyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Kyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Kzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
gxxx = gxxx - ( Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz &
|
||||
+ Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz)
|
||||
gxyx = gxyx - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz &
|
||||
+ Gamxxx * Kxy + Gamyxx * Kyy + Gamzxx * Kyz)
|
||||
gxzx = gxzx - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz &
|
||||
+ Gamxxx * Kxz + Gamyxx * Kyz + Gamzxx * Kzz)
|
||||
gyyx = gyyx - ( Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz &
|
||||
+ Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz)
|
||||
gyzx = gyzx - ( Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz &
|
||||
+ Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz)
|
||||
gzzx = gzzx - ( Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz &
|
||||
+ Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz)
|
||||
gxxy = gxxy - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz &
|
||||
+ Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz)
|
||||
gxyy = gxyy - ( Gamxyy * Kxx + Gamyyy * Kxy + Gamzyy * Kxz &
|
||||
+ Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz)
|
||||
gxzy = gxzy - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz &
|
||||
+ Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz)
|
||||
gyyy = gyyy - ( Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz &
|
||||
+ Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz)
|
||||
gyzy = gyzy - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz &
|
||||
+ Gamxyy * Kxz + Gamyyy * Kyz + Gamzyy * Kzz)
|
||||
gzzy = gzzy - ( Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz &
|
||||
+ Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz)
|
||||
gxxz = gxxz - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz &
|
||||
+ Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz)
|
||||
gxyz = gxyz - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz &
|
||||
+ Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz)
|
||||
gxzz = gxzz - ( Gamxzz * Kxx + Gamyzz * Kxy + Gamzzz * Kxz &
|
||||
+ Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz)
|
||||
gyyz = gyyz - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz &
|
||||
+ Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz)
|
||||
gyzz = gyzz - ( Gamxzz * Kxy + Gamyzz * Kyy + Gamzzz * Kyz &
|
||||
+ Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz)
|
||||
gzzz = gzzz - ( Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz &
|
||||
+ Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz)
|
||||
movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz &
|
||||
+gupxy*gxyx + gupxz*gxzx + gupyz*gxzy &
|
||||
+gupxy*gxxy + gupxz*gxxz + gupyz*gxyz
|
||||
movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz &
|
||||
+gupxy*gyyx + gupxz*gyzx + gupyz*gyzy &
|
||||
+gupxy*gxyy + gupxz*gxyz + gupyz*gyyz
|
||||
movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz &
|
||||
+gupxy*gyzx + gupxz*gzzx + gupyz*gzzy &
|
||||
+gupxy*gxzy + gupxz*gxzz + gupyz*gyzz
|
||||
|
||||
call fderivs_shc(ex,trK,fx,fy,fz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
movx_Res = movx_Res - fx - F8*PI*sx
|
||||
movy_Res = movy_Res - fy - F8*PI*sy
|
||||
movz_Res = movz_Res - fz - F8*PI*sz
|
||||
|
||||
return
|
||||
|
||||
end subroutine constraint_adm_ss
|
||||
40
AMSS_NCKU_source/BSSN/bssn2adm.f90
Normal file
40
AMSS_NCKU_source/BSSN/bssn2adm.f90
Normal file
@@ -0,0 +1,40 @@
|
||||
|
||||
!-------------------------------------------------------------------------------!
|
||||
! convert bssn variables to ADM variables !
|
||||
!-------------------------------------------------------------------------------!
|
||||
subroutine bssn2adm(ex,chi,trK, &
|
||||
gxx,gxy,gxz,gyy,gyz,gzz, &
|
||||
Axx,Axy,Axz,Ayy,Ayz,Azz, &
|
||||
adm_gxx,adm_gxy,adm_gxz,adm_gyy,adm_gyz,adm_gzz, &
|
||||
Kxx,Kxy,Kxz,Kyy,Kyz,Kzz)
|
||||
|
||||
implicit none
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer,intent(in ):: ex(1:3)
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::chi,trK
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::gxx,gxy,gxz,gyy,gyz,gzz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::Axx,Axy,Axz,Ayy,Ayz,Azz
|
||||
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: adm_gxx,adm_gxy,adm_gxz,adm_gyy,adm_gyz,adm_gzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz
|
||||
|
||||
real*8, parameter :: F1o3=1.d0/3.d0
|
||||
|
||||
adm_gxx = gxx/chi
|
||||
adm_gxy = gxy/chi
|
||||
adm_gxz = gxz/chi
|
||||
adm_gyy = gyy/chi
|
||||
adm_gyz = gyz/chi
|
||||
adm_gzz = gzz/chi
|
||||
|
||||
Kxx = Axx/chi+F1o3*trK*adm_gxx
|
||||
Kxy = Axy/chi+F1o3*trK*adm_gxy
|
||||
Kxz = Axz/chi+F1o3*trK*adm_gxz
|
||||
Kyy = Ayy/chi+F1o3*trK*adm_gyy
|
||||
Kyz = Ayz/chi+F1o3*trK*adm_gyz
|
||||
Kzz = Azz/chi+F1o3*trK*adm_gzz
|
||||
|
||||
return
|
||||
|
||||
end subroutine bssn2adm
|
||||
2325
AMSS_NCKU_source/BSSN/bssnEM_class.C
Normal file
2325
AMSS_NCKU_source/BSSN/bssnEM_class.C
Normal file
File diff suppressed because it is too large
Load Diff
69
AMSS_NCKU_source/BSSN/bssnEM_class.h
Normal file
69
AMSS_NCKU_source/BSSN/bssnEM_class.h
Normal file
@@ -0,0 +1,69 @@
|
||||
|
||||
#ifndef BSSNEM_CLASS_H
|
||||
#define BSSNEM_CLASS_H
|
||||
|
||||
#ifdef newc
|
||||
#include <iostream>
|
||||
#include <iomanip>
|
||||
#include <fstream>
|
||||
#include <cstdlib>
|
||||
#include <string>
|
||||
#include <cmath>
|
||||
using namespace std;
|
||||
#else
|
||||
#include <iostream.h>
|
||||
#include <iomanip.h>
|
||||
#include <fstream.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <math.h>
|
||||
#endif
|
||||
|
||||
#include <mpi.h>
|
||||
|
||||
#include "cgh.h"
|
||||
#include "ShellPatch.h"
|
||||
#include "misc.h"
|
||||
#include "var.h"
|
||||
#include "MyList.h"
|
||||
#include "monitor.h"
|
||||
#include "surface_integral.h"
|
||||
|
||||
#include "macrodef.h"
|
||||
|
||||
#ifdef USE_GPU
|
||||
#include "bssn_gpu_class.h"
|
||||
#else
|
||||
#include "bssn_class.h"
|
||||
#endif
|
||||
|
||||
class bssnEM_class : public bssn_class
|
||||
{
|
||||
public:
|
||||
bssnEM_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei,
|
||||
int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi,
|
||||
int a_levi, int maxli, int decni, double maxrexi, double drexi);
|
||||
~bssnEM_class();
|
||||
|
||||
void Initialize();
|
||||
void Read_Ansorg();
|
||||
void Setup_Initial_Data();
|
||||
void Step(int lev, int YN);
|
||||
void Compute_Phi2(int lev);
|
||||
void AnalysisStuff_EM(int lev, double dT_lev);
|
||||
void Interp_Constraint();
|
||||
|
||||
protected:
|
||||
var *Exo, *Eyo, *Ezo, *Bxo, *Byo, *Bzo, *Kpsio, *Kphio;
|
||||
var *Ex0, *Ey0, *Ez0, *Bx0, *By0, *Bz0, *Kpsi0, *Kphi0;
|
||||
var *Ex, *Ey, *Ez, *Bx, *By, *Bz, *Kpsi, *Kphi;
|
||||
var *Ex1, *Ey1, *Ez1, *Bx1, *By1, *Bz1, *Kpsi1, *Kphi1;
|
||||
var *Ex_rhs, *Ey_rhs, *Ez_rhs, *Bx_rhs, *By_rhs, *Bz_rhs, *Kpsi_rhs, *Kphi_rhs;
|
||||
var *Jx, *Jy, *Jz, *qchar;
|
||||
var *Rphi2, *Iphi2;
|
||||
var *Rphi1, *Iphi1;
|
||||
|
||||
monitor *Phi2Monitor;
|
||||
monitor *Phi1Monitor;
|
||||
};
|
||||
#endif /* BSSNEM_CLASS_H */
|
||||
8735
AMSS_NCKU_source/BSSN/bssn_class.C
Normal file
8735
AMSS_NCKU_source/BSSN/bssn_class.C
Normal file
File diff suppressed because it is too large
Load Diff
206
AMSS_NCKU_source/BSSN/bssn_class.h
Normal file
206
AMSS_NCKU_source/BSSN/bssn_class.h
Normal file
@@ -0,0 +1,206 @@
|
||||
|
||||
#ifndef BSSN_CLASS_H
|
||||
#define BSSN_CLASS_H
|
||||
|
||||
#ifdef newc
|
||||
#include <iostream>
|
||||
#include <iomanip>
|
||||
#include <fstream>
|
||||
#include <cstdlib>
|
||||
#include <string>
|
||||
#include <cmath>
|
||||
using namespace std;
|
||||
#else
|
||||
#include <iostream.h>
|
||||
#include <iomanip.h>
|
||||
#include <fstream.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <math.h>
|
||||
#endif
|
||||
|
||||
#include <mpi.h>
|
||||
|
||||
#include "macrodef.h"
|
||||
#include "cgh.h"
|
||||
#include "ShellPatch.h"
|
||||
#include "misc.h"
|
||||
#include "var.h"
|
||||
#include "MyList.h"
|
||||
#include "monitor.h"
|
||||
#include "surface_integral.h"
|
||||
#include "checkpoint.h"
|
||||
|
||||
extern void setpbh(int iBHN, double **iPBH, double *iMass, int rBHN);
|
||||
|
||||
class bssn_class
|
||||
{
|
||||
public:
|
||||
int ngfs;
|
||||
int nprocs, myrank;
|
||||
cgh *GH;
|
||||
ShellPatch *SH;
|
||||
double PhysTime;
|
||||
|
||||
int checkrun;
|
||||
char checkfilename[50];
|
||||
int Steps;
|
||||
double StartTime, TotalTime;
|
||||
double AnasTime, DumpTime, d2DumpTime, CheckTime;
|
||||
double LastAnas, LastConsOut;
|
||||
int *ConstraintRefreshLevels;
|
||||
double Courant;
|
||||
double numepss, numepsb, numepsh;
|
||||
int Symmetry;
|
||||
int maxl, decn;
|
||||
double maxrex, drex;
|
||||
int trfls, a_lev;
|
||||
|
||||
double dT;
|
||||
double chitiny;
|
||||
|
||||
double **Porg0, **Porgbr, **Porg, **Porg1, **Porg_rhs;
|
||||
int BH_num, BH_num_input;
|
||||
double *Mass, *Pmom, *Spin;
|
||||
double ADMMass;
|
||||
|
||||
var *phio, *trKo;
|
||||
var *gxxo, *gxyo, *gxzo, *gyyo, *gyzo, *gzzo;
|
||||
var *Axxo, *Axyo, *Axzo, *Ayyo, *Ayzo, *Azzo;
|
||||
var *Gmxo, *Gmyo, *Gmzo;
|
||||
var *Lapo, *Sfxo, *Sfyo, *Sfzo;
|
||||
var *dtSfxo, *dtSfyo, *dtSfzo;
|
||||
|
||||
var *phi0, *trK0;
|
||||
var *gxx0, *gxy0, *gxz0, *gyy0, *gyz0, *gzz0;
|
||||
var *Axx0, *Axy0, *Axz0, *Ayy0, *Ayz0, *Azz0;
|
||||
var *Gmx0, *Gmy0, *Gmz0;
|
||||
var *Lap0, *Sfx0, *Sfy0, *Sfz0;
|
||||
var *dtSfx0, *dtSfy0, *dtSfz0;
|
||||
|
||||
var *phi, *trK;
|
||||
var *gxx, *gxy, *gxz, *gyy, *gyz, *gzz;
|
||||
var *Axx, *Axy, *Axz, *Ayy, *Ayz, *Azz;
|
||||
var *Gmx, *Gmy, *Gmz;
|
||||
var *Lap, *Sfx, *Sfy, *Sfz;
|
||||
var *dtSfx, *dtSfy, *dtSfz;
|
||||
|
||||
var *phi1, *trK1;
|
||||
var *gxx1, *gxy1, *gxz1, *gyy1, *gyz1, *gzz1;
|
||||
var *Axx1, *Axy1, *Axz1, *Ayy1, *Ayz1, *Azz1;
|
||||
var *Gmx1, *Gmy1, *Gmz1;
|
||||
var *Lap1, *Sfx1, *Sfy1, *Sfz1;
|
||||
var *dtSfx1, *dtSfy1, *dtSfz1;
|
||||
|
||||
var *phi_rhs, *trK_rhs;
|
||||
var *gxx_rhs, *gxy_rhs, *gxz_rhs, *gyy_rhs, *gyz_rhs, *gzz_rhs;
|
||||
var *Axx_rhs, *Axy_rhs, *Axz_rhs, *Ayy_rhs, *Ayz_rhs, *Azz_rhs;
|
||||
var *Gmx_rhs, *Gmy_rhs, *Gmz_rhs;
|
||||
var *Lap_rhs, *Sfx_rhs, *Sfy_rhs, *Sfz_rhs;
|
||||
var *dtSfx_rhs, *dtSfy_rhs, *dtSfz_rhs;
|
||||
|
||||
var *rho, *Sx, *Sy, *Sz, *Sxx, *Sxy, *Sxz, *Syy, *Syz, *Szz;
|
||||
|
||||
var *Gamxxx, *Gamxxy, *Gamxxz, *Gamxyy, *Gamxyz, *Gamxzz;
|
||||
var *Gamyxx, *Gamyxy, *Gamyxz, *Gamyyy, *Gamyyz, *Gamyzz;
|
||||
var *Gamzxx, *Gamzxy, *Gamzxz, *Gamzyy, *Gamzyz, *Gamzzz;
|
||||
|
||||
var *Rxx, *Rxy, *Rxz, *Ryy, *Ryz, *Rzz;
|
||||
|
||||
var *Rpsi4, *Ipsi4;
|
||||
var *t1Rpsi4, *t1Ipsi4, *t2Rpsi4, *t2Ipsi4;
|
||||
|
||||
var *Cons_Ham, *Cons_Px, *Cons_Py, *Cons_Pz, *Cons_Gx, *Cons_Gy, *Cons_Gz;
|
||||
|
||||
#ifdef Point_Psi4
|
||||
var *phix, *phiy, *phiz;
|
||||
var *trKx, *trKy, *trKz;
|
||||
var *Axxx, *Axxy, *Axxz;
|
||||
var *Axyx, *Axyy, *Axyz;
|
||||
var *Axzx, *Axzy, *Axzz;
|
||||
var *Ayyx, *Ayyy, *Ayyz;
|
||||
var *Ayzx, *Ayzy, *Ayzz;
|
||||
var *Azzx, *Azzy, *Azzz;
|
||||
#endif
|
||||
// FIXME: uc = StateList, up = OldStateList, upp = SynchList_cor; so never touch these three data
|
||||
MyList<var> *StateList, *SynchList_pre, *SynchList_cor, *RHSList;
|
||||
MyList<var> *OldStateList, *DumpList;
|
||||
MyList<var> *ConstraintList;
|
||||
|
||||
Parallel::SyncCache *sync_cache_pre; // per-level cache for predictor sync
|
||||
Parallel::SyncCache *sync_cache_cor; // per-level cache for corrector sync
|
||||
Parallel::SyncCache *sync_cache_rp_coarse; // RestrictProlong sync on PatL[lev-1]
|
||||
Parallel::SyncCache *sync_cache_rp_fine; // RestrictProlong sync on PatL[lev]
|
||||
Parallel::SyncCache *sync_cache_restrict; // cached Restrict in RestrictProlong
|
||||
Parallel::SyncCache *sync_cache_outbd; // cached OutBdLow2Hi in RestrictProlong
|
||||
|
||||
monitor *ErrorMonitor, *Psi4Monitor, *BHMonitor, *MAPMonitor;
|
||||
monitor *ConVMonitor, *TimingMonitor;
|
||||
surface_integral *Waveshell;
|
||||
checkpoint *CheckPoint;
|
||||
|
||||
public:
|
||||
bssn_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei,
|
||||
int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi,
|
||||
int a_levi, int maxli, int decni, double maxrexi, double drexi);
|
||||
~bssn_class();
|
||||
|
||||
void Evolve(int Steps);
|
||||
void RecursiveStep(int lev);
|
||||
#if (PSTR == 3)
|
||||
void RecursiveStep(int lev, int num);
|
||||
#endif
|
||||
#if (PSTR == 1 || PSTR == 2 || PSTR == 3)
|
||||
void ParallelStep();
|
||||
void SHStep();
|
||||
#endif
|
||||
void RestrictProlong(int lev, int YN, bool BB, MyList<var> *SL, MyList<var> *OL, MyList<var> *corL);
|
||||
void RestrictProlong_aux(int lev, int YN, bool BB, MyList<var> *SL, MyList<var> *OL, MyList<var> *corL);
|
||||
void RestrictProlong(int lev, int YN, bool BB);
|
||||
void ProlongRestrict(int lev, int YN, bool BB);
|
||||
void Setup_Black_Hole_position();
|
||||
void compute_Porg_rhs(double **BH_PS, double **BH_RHS, var *forx, var *fory, var *forz, int lev);
|
||||
bool read_Pablo_file(int *ext, double *datain, char *filename);
|
||||
void write_Pablo_file(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax,
|
||||
char *filename);
|
||||
void AnalysisStuff(int lev, double dT_lev);
|
||||
void Setup_KerrSchild();
|
||||
void Enforce_algcon(int lev, int fg);
|
||||
|
||||
void testRestrict();
|
||||
void testOutBd();
|
||||
|
||||
bool check_Stdin_Abort();
|
||||
|
||||
virtual void Setup_Initial_Data_Cao();
|
||||
virtual void Setup_Initial_Data_Lousto();
|
||||
virtual void Initialize();
|
||||
virtual void Read_Ansorg();
|
||||
virtual void Read_Pablo() {};
|
||||
virtual void Compute_Psi4(int lev);
|
||||
virtual void Step(int lev, int YN);
|
||||
virtual void Interp_Constraint(bool infg);
|
||||
virtual void Constraint_Out();
|
||||
virtual void Compute_Constraint();
|
||||
|
||||
#ifdef With_AHF
|
||||
protected:
|
||||
MyList<var> *AHList, *AHDList, *GaugeList;
|
||||
int AHfindevery;
|
||||
double AHdumptime;
|
||||
int *lastahdumpid, HN_num; // number of possible horizons
|
||||
int *findeveryl;
|
||||
double *xc, *yc, *zc, *xr, *yr, *zr;
|
||||
bool *trigger;
|
||||
double *dTT;
|
||||
int *dumpid;
|
||||
|
||||
public:
|
||||
void AH_Prepare_derivatives();
|
||||
bool AH_Interp_Points(MyList<var> *VarList,
|
||||
int NN, double **XX,
|
||||
double *Shellf, int Symmetryi);
|
||||
void AH_Step_Find(int lev, double dT_lev);
|
||||
#endif
|
||||
};
|
||||
#endif /* BSSN_CLASS_H */
|
||||
787
AMSS_NCKU_source/BSSN/bssn_constraint.f90
Normal file
787
AMSS_NCKU_source/BSSN/bssn_constraint.f90
Normal file
@@ -0,0 +1,787 @@
|
||||
|
||||
|
||||
#include "macrodef.fh"
|
||||
|
||||
#if (ABV == 0)
|
||||
!! using BSSN variables
|
||||
!-------------------------------------------------------------------------------!
|
||||
! computed constraint for bssn formalism !
|
||||
!-------------------------------------------------------------------------------!
|
||||
subroutine constraint_bssn(ex, X, Y, Z,&
|
||||
chi,trK, &
|
||||
dxx,gxy,gxz,dyy,gyz,dzz, &
|
||||
Axx,Axy,Axz,Ayy,Ayz,Azz, &
|
||||
Gmx,Gmy,Gmz,&
|
||||
Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,&
|
||||
Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, &
|
||||
Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, &
|
||||
Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, &
|
||||
Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, &
|
||||
ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, &
|
||||
Symmetry)
|
||||
|
||||
implicit none
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer,intent(in ):: ex(1:3),symmetry
|
||||
real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3))
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz
|
||||
! second kind of Christofel symble Gamma^i_jk respect to physical metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res
|
||||
!~~~~~~> Other variables:
|
||||
! inverse metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz
|
||||
! first order derivative of metric, @_k g_ij
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz
|
||||
! partial derivative of chi, chi_i
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: chin1,chix,chiy,chiz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz
|
||||
|
||||
integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2
|
||||
real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0
|
||||
real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0
|
||||
real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0
|
||||
real*8 :: PI
|
||||
|
||||
PI = dacos(-ONE)
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
chin1 = chi+ONE
|
||||
! invert tilted metric
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0)
|
||||
call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0)
|
||||
call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0)
|
||||
call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
|
||||
! Gam^i_Res = Gam^i + gup^ij_,j
|
||||
Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)&
|
||||
+gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)&
|
||||
+gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)&
|
||||
+gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)&
|
||||
+gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)&
|
||||
+gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)&
|
||||
+gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)&
|
||||
+gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)&
|
||||
+gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)&
|
||||
+gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)&
|
||||
+gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)&
|
||||
+gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)&
|
||||
+gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)&
|
||||
+gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)&
|
||||
+gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)&
|
||||
+gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)&
|
||||
+gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)&
|
||||
+gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)&
|
||||
+gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
|
||||
! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho
|
||||
! here trR is respect to physical metric
|
||||
ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + &
|
||||
TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz )
|
||||
|
||||
ham_Res = chin1*ham_Res + F2o3 * trK * trK -(&
|
||||
gupxx * ( &
|
||||
gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + &
|
||||
TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + &
|
||||
gupyy * ( &
|
||||
gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + &
|
||||
TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + &
|
||||
gupzz * ( &
|
||||
gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + &
|
||||
TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + &
|
||||
TWO * ( &
|
||||
gupxy * ( &
|
||||
gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + &
|
||||
gupxy * (Axx * Ayy + Axy * Axy) + &
|
||||
gupxz * (Axx * Ayz + Axz * Axy) + &
|
||||
gupyz * (Axy * Ayz + Axz * Ayy) ) + &
|
||||
gupxz * ( &
|
||||
gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + &
|
||||
gupxy * (Axx * Ayz + Axy * Axz) + &
|
||||
gupxz * (Axx * Azz + Axz * Axz) + &
|
||||
gupyz * (Axy * Azz + Axz * Ayz) ) + &
|
||||
gupyz * ( &
|
||||
gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + &
|
||||
gupxy * (Axy * Ayz + Ayy * Axz) + &
|
||||
gupxz * (Axy * Azz + Ayz * Axz) + &
|
||||
gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho
|
||||
|
||||
! M_j = gupki*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric
|
||||
! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i
|
||||
call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
call fderivs(ex,Axx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
call fderivs(ex,Axy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0)
|
||||
call fderivs(ex,Axz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0)
|
||||
call fderivs(ex,Ayy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
call fderivs(ex,Ayz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0)
|
||||
call fderivs(ex,Azz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
|
||||
gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz &
|
||||
+ Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1
|
||||
gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz &
|
||||
+ Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1
|
||||
gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz &
|
||||
+ Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1
|
||||
gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz &
|
||||
+ Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1
|
||||
gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz &
|
||||
+ Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1
|
||||
gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz &
|
||||
+ Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1
|
||||
gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz &
|
||||
+ Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1
|
||||
gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz &
|
||||
+ Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1
|
||||
gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz &
|
||||
+ Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1
|
||||
gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz &
|
||||
+ Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1
|
||||
gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz &
|
||||
+ Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1
|
||||
gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz &
|
||||
+ Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1
|
||||
gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz &
|
||||
+ Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1
|
||||
gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz &
|
||||
+ Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1
|
||||
gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz &
|
||||
+ Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1
|
||||
gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz &
|
||||
+ Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1
|
||||
gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz &
|
||||
+ Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1
|
||||
gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz &
|
||||
+ Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1
|
||||
movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz &
|
||||
+gupxy*gxyx + gupxz*gxzx + gupyz*gxzy &
|
||||
+gupxy*gxxy + gupxz*gxxz + gupyz*gxyz
|
||||
movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz &
|
||||
+gupxy*gyyx + gupxz*gyzx + gupyz*gyzy &
|
||||
+gupxy*gxyy + gupxz*gxyz + gupyz*gyyz
|
||||
movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz &
|
||||
+gupxy*gyzx + gupxz*gzzx + gupyz*gzzy &
|
||||
+gupxy*gxzy + gupxz*gxzz + gupyz*gyzz
|
||||
|
||||
!store K,i in chi,i
|
||||
call fderivs(ex,trK,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,Symmetry,0)
|
||||
|
||||
movx_Res = movx_Res - F2o3*chix - F8*PI*sx
|
||||
movy_Res = movy_Res - F2o3*chiy - F8*PI*sy
|
||||
movz_Res = movz_Res - F2o3*chiz - F8*PI*sz
|
||||
|
||||
return
|
||||
|
||||
end subroutine constraint_bssn
|
||||
!-------------------------------------------------------------------------------!
|
||||
! computed constraint for bssn formalism for shell !
|
||||
!-------------------------------------------------------------------------------!
|
||||
subroutine constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz, &
|
||||
drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, &
|
||||
dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, &
|
||||
dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, &
|
||||
chi,trK, &
|
||||
dxx,gxy,gxz,dyy,gyz,dzz, &
|
||||
Axx,Axy,Axz,Ayy,Ayz,Azz, &
|
||||
Gmx,Gmy,Gmz,&
|
||||
Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,&
|
||||
Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, &
|
||||
Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, &
|
||||
Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, &
|
||||
Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, &
|
||||
ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, &
|
||||
Symmetry,Lev,sst)
|
||||
|
||||
implicit none
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer,intent(in ):: ex(1:3),symmetry,Lev,sst
|
||||
double precision,intent(in),dimension(ex(1))::crho
|
||||
double precision,intent(in),dimension(ex(2))::sigma
|
||||
double precision,intent(in),dimension(ex(3))::R
|
||||
real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz
|
||||
! second kind of Christofel symble Gamma^i_jk respect to physical metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res
|
||||
!~~~~~~> Other variables:
|
||||
! inverse metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz
|
||||
! first order derivative of metric, @_k g_ij
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz
|
||||
! partial derivative of chi, chi_i
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: chin1,chix,chiy,chiz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz
|
||||
|
||||
integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2
|
||||
real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0
|
||||
real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0
|
||||
real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0
|
||||
real*8 :: PI
|
||||
|
||||
PI = dacos(-ONE)
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
chin1 = chi+ONE
|
||||
! invert tilted metric
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
! Gam^i_Res = Gam^i + gup^ij_,j
|
||||
Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)&
|
||||
+gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)&
|
||||
+gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)&
|
||||
+gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)&
|
||||
+gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)&
|
||||
+gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)&
|
||||
+gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)&
|
||||
+gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)&
|
||||
+gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)&
|
||||
+gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)&
|
||||
+gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)&
|
||||
+gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)&
|
||||
+gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)&
|
||||
+gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)&
|
||||
+gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)&
|
||||
+gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)&
|
||||
+gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)&
|
||||
+gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)&
|
||||
+gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
|
||||
! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho
|
||||
! here trR is respect to physical metric
|
||||
ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + &
|
||||
TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz )
|
||||
|
||||
ham_Res = chin1*ham_Res + F2o3 * trK * trK -(&
|
||||
gupxx * ( &
|
||||
gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + &
|
||||
TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + &
|
||||
gupyy * ( &
|
||||
gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + &
|
||||
TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + &
|
||||
gupzz * ( &
|
||||
gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + &
|
||||
TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + &
|
||||
TWO * ( &
|
||||
gupxy * ( &
|
||||
gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + &
|
||||
gupxy * (Axx * Ayy + Axy * Axy) + &
|
||||
gupxz * (Axx * Ayz + Axz * Axy) + &
|
||||
gupyz * (Axy * Ayz + Axz * Ayy) ) + &
|
||||
gupxz * ( &
|
||||
gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + &
|
||||
gupxy * (Axx * Ayz + Axy * Axz) + &
|
||||
gupxz * (Axx * Azz + Axz * Axz) + &
|
||||
gupyz * (Axy * Azz + Axz * Ayz) ) + &
|
||||
gupyz * ( &
|
||||
gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + &
|
||||
gupxy * (Axy * Ayz + Ayy * Axz) + &
|
||||
gupxz * (Axy * Azz + Ayz * Axz) + &
|
||||
gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho
|
||||
|
||||
! M_j = gupki*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric
|
||||
! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i
|
||||
call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Axx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Axy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Axz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Ayy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Ayz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,Azz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz &
|
||||
+ Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1
|
||||
gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz &
|
||||
+ Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1
|
||||
gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz &
|
||||
+ Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1
|
||||
gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz &
|
||||
+ Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1
|
||||
gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz &
|
||||
+ Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1
|
||||
gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz &
|
||||
+ Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1
|
||||
gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz &
|
||||
+ Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1
|
||||
gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz &
|
||||
+ Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1
|
||||
gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz &
|
||||
+ Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1
|
||||
gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz &
|
||||
+ Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1
|
||||
gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz &
|
||||
+ Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1
|
||||
gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz &
|
||||
+ Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1
|
||||
gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz &
|
||||
+ Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1
|
||||
gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz &
|
||||
+ Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1
|
||||
gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz &
|
||||
+ Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1
|
||||
gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz &
|
||||
+ Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1
|
||||
gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz &
|
||||
+ Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1
|
||||
gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz &
|
||||
+ Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1
|
||||
movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz &
|
||||
+gupxy*gxyx + gupxz*gxzx + gupyz*gxzy &
|
||||
+gupxy*gxxy + gupxz*gxxz + gupyz*gxyz
|
||||
movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz &
|
||||
+gupxy*gyyx + gupxz*gyzx + gupyz*gyzy &
|
||||
+gupxy*gxyy + gupxz*gxyz + gupyz*gyyz
|
||||
movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz &
|
||||
+gupxy*gyzx + gupxz*gzzx + gupyz*gzzy &
|
||||
+gupxy*gxzy + gupxz*gxzz + gupyz*gyzz
|
||||
|
||||
!store K,i in chi,i
|
||||
call fderivs_shc(ex,trK,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
movx_Res = movx_Res - F2o3*chix - F8*PI*sx
|
||||
movy_Res = movy_Res - F2o3*chiy - F8*PI*sy
|
||||
movz_Res = movz_Res - F2o3*chiz - F8*PI*sz
|
||||
|
||||
return
|
||||
|
||||
end subroutine constraint_bssn_ss
|
||||
#elif (ABV == 1)
|
||||
!! using ADM variables
|
||||
!-------------------------------------------------------------------------------!
|
||||
! computed constraint for bssn formalism !
|
||||
!-------------------------------------------------------------------------------!
|
||||
subroutine constraint_bssn(ex, X, Y, Z,&
|
||||
chi,trK, &
|
||||
dxx,gxy,gxz,dyy,gyz,dzz, &
|
||||
Axx,Axy,Axz,Ayy,Ayz,Azz, &
|
||||
Gmx,Gmy,Gmz,&
|
||||
Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,&
|
||||
Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, &
|
||||
Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, &
|
||||
Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, &
|
||||
Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, &
|
||||
ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, &
|
||||
Symmetry)
|
||||
|
||||
implicit none
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer,intent(in ):: ex(1:3),symmetry
|
||||
real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3))
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz
|
||||
! second kind of Christofel symble Gamma^i_jk respect to physical metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res
|
||||
!~~~~~~> Other variables:
|
||||
! inverse metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz
|
||||
! first order derivative of metric, @_k g_ij
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz
|
||||
! partial derivative of chi, chi_i
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: chin1
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: adm_dxx,adm_dyy,adm_dzz,adm_gxy,adm_gxz,adm_gyz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kyy,Kzz,Kxy,Kxz,Kyz
|
||||
|
||||
integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2
|
||||
real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0
|
||||
real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0
|
||||
real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0
|
||||
real*8 :: PI
|
||||
|
||||
PI = dacos(-ONE)
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
chin1 = chi+ONE
|
||||
! invert tilted metric
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0)
|
||||
call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0)
|
||||
call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0)
|
||||
call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0)
|
||||
|
||||
! Gam^i_Res = Gam^i + gup^ij_,j
|
||||
Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)&
|
||||
+gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)&
|
||||
+gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)&
|
||||
+gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)&
|
||||
+gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)&
|
||||
+gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)&
|
||||
+gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)&
|
||||
+gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)&
|
||||
+gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)&
|
||||
+gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)&
|
||||
+gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)&
|
||||
+gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)&
|
||||
+gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)&
|
||||
+gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)&
|
||||
+gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)&
|
||||
+gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)&
|
||||
+gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)&
|
||||
+gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)&
|
||||
+gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
|
||||
call bssn2adm(ex,chin1,trK,gxx,gxy,gxz,gyy,gyz,gzz, &
|
||||
Axx,Axy,Axz,Ayy,Ayz,Azz, &
|
||||
adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, &
|
||||
Kxx,Kxy,Kxz,Kyy,Kyz,Kzz)
|
||||
adm_dxx = adm_dxx - ONE
|
||||
adm_dyy = adm_dyy - ONE
|
||||
adm_dzz = adm_dzz - ONE
|
||||
|
||||
call constraint_adm(ex, X, Y, Z,&
|
||||
adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, &
|
||||
Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, &
|
||||
Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,&
|
||||
ham_Res, movx_Res, movy_Res, movz_Res, &
|
||||
Symmetry)
|
||||
|
||||
return
|
||||
|
||||
end subroutine constraint_bssn
|
||||
!-------------------------------------------------------------------------------!
|
||||
! computed constraint for bssn formalism for shell !
|
||||
!-------------------------------------------------------------------------------!
|
||||
subroutine constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz, &
|
||||
drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, &
|
||||
dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, &
|
||||
dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, &
|
||||
chi,trK, &
|
||||
dxx,gxy,gxz,dyy,gyz,dzz, &
|
||||
Axx,Axy,Axz,Ayy,Ayz,Azz, &
|
||||
Gmx,Gmy,Gmz,&
|
||||
Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,&
|
||||
Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, &
|
||||
Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, &
|
||||
Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, &
|
||||
Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, &
|
||||
ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, &
|
||||
Symmetry,Lev,sst)
|
||||
|
||||
implicit none
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer,intent(in ):: ex(1:3),symmetry,Lev,sst
|
||||
double precision,intent(in),dimension(ex(1))::crho
|
||||
double precision,intent(in),dimension(ex(2))::sigma
|
||||
double precision,intent(in),dimension(ex(3))::R
|
||||
real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz
|
||||
! second kind of Christofel symble Gamma^i_jk respect to physical metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res
|
||||
!~~~~~~> Other variables:
|
||||
! inverse metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz
|
||||
! first order derivative of metric, @_k g_ij
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz
|
||||
! partial derivative of chi, chi_i
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: chin1
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: adm_dxx,adm_dyy,adm_dzz,adm_gxy,adm_gxz,adm_gyz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kyy,Kzz,Kxy,Kxz,Kyz
|
||||
|
||||
integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2
|
||||
real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0
|
||||
real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0
|
||||
real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0
|
||||
real*8 :: PI
|
||||
|
||||
PI = dacos(-ONE)
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
chin1 = chi+ONE
|
||||
! invert tilted metric
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
! Gam^i_Res = Gam^i + gup^ij_,j
|
||||
Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)&
|
||||
+gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)&
|
||||
+gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)&
|
||||
+gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)&
|
||||
+gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)&
|
||||
+gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)&
|
||||
+gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)&
|
||||
+gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)&
|
||||
+gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)&
|
||||
+gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)&
|
||||
+gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)&
|
||||
+gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)&
|
||||
+gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)&
|
||||
+gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)&
|
||||
+gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)&
|
||||
+gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)&
|
||||
+gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)&
|
||||
+gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)&
|
||||
+gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)&
|
||||
+gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)&
|
||||
+gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz))
|
||||
|
||||
call bssn2adm(ex,chin1,trK,gxx,gxy,gxz,gyy,gyz,gzz, &
|
||||
Axx,Axy,Axz,Ayy,Ayz,Azz, &
|
||||
adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, &
|
||||
Kxx,Kxy,Kxz,Kyy,Kyz,Kzz)
|
||||
adm_dxx = adm_dxx - ONE
|
||||
adm_dyy = adm_dyy - ONE
|
||||
adm_dzz = adm_dzz - ONE
|
||||
|
||||
call constraint_adm_ss(ex,crho,sigma,R, X, Y, Z,&
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz, &
|
||||
drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, &
|
||||
dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, &
|
||||
dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, &
|
||||
adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, &
|
||||
Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, &
|
||||
Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,&
|
||||
Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, &
|
||||
Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, &
|
||||
Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, &
|
||||
Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, &
|
||||
ham_Res, movx_Res, movy_Res, movz_Res, &
|
||||
Symmetry,Lev,sst)
|
||||
|
||||
return
|
||||
|
||||
end subroutine constraint_bssn_ss
|
||||
#else
|
||||
#error "not recognized ABV"
|
||||
#endif
|
||||
1197
AMSS_NCKU_source/BSSN/bssn_rhs.f90
Normal file
1197
AMSS_NCKU_source/BSSN/bssn_rhs.f90
Normal file
File diff suppressed because it is too large
Load Diff
244
AMSS_NCKU_source/BSSN/bssn_rhs.h
Normal file
244
AMSS_NCKU_source/BSSN/bssn_rhs.h
Normal file
@@ -0,0 +1,244 @@
|
||||
|
||||
#ifndef BSSN_H
|
||||
#define BSSN_H
|
||||
|
||||
#ifdef fortran1
|
||||
#define f_compute_rhs_bssn compute_rhs_bssn
|
||||
#define f_compute_rhs_bssn_ss compute_rhs_bssn_ss
|
||||
#define f_compute_rhs_bssn_escalar compute_rhs_bssn_escalar
|
||||
#define f_compute_rhs_bssn_escalar_ss compute_rhs_bssn_escalar_ss
|
||||
#define f_compute_rhs_Z4c compute_rhs_z4c
|
||||
#define f_compute_rhs_Z4cnot compute_rhs_z4cnot
|
||||
#define f_compute_rhs_Z4c_ss compute_rhs_z4c_ss
|
||||
#define f_compute_constraint_fr compute_constraint_fr
|
||||
#endif
|
||||
#ifdef fortran2
|
||||
#define f_compute_rhs_bssn COMPUTE_RHS_BSSN
|
||||
#define f_compute_rhs_bssn_ss COMPUTE_RHS_BSSN_SS
|
||||
#define f_compute_rhs_bssn_escalar COMPUTE_RHS_BSSN_ESCALAR
|
||||
#define f_compute_rhs_bssn_escalar_ss COMPUTE_RHS_BSSN_ESCALAR_SS
|
||||
#define f_compute_rhs_Z4c COMPUTE_RHS_Z4C
|
||||
#define f_compute_rhs_Z4cnot COMPUTE_RHS_Z4CNOT
|
||||
#define f_compute_rhs_Z4c_ss COMPUTE_RHS_Z4C_SS
|
||||
#define f_compute_constraint_fr COMPUTE_CONSTRAINT_FR
|
||||
#endif
|
||||
#ifdef fortran3
|
||||
#define f_compute_rhs_bssn compute_rhs_bssn_
|
||||
#define f_compute_rhs_bssn_ss compute_rhs_bssn_ss_
|
||||
#define f_compute_rhs_bssn_escalar compute_rhs_bssn_escalar_
|
||||
#define f_compute_rhs_bssn_escalar_ss compute_rhs_bssn_escalar_ss_
|
||||
#define f_compute_rhs_Z4c compute_rhs_z4c_
|
||||
#define f_compute_rhs_Z4cnot compute_rhs_z4cnot_
|
||||
#define f_compute_rhs_Z4c_ss compute_rhs_z4c_ss_
|
||||
#define f_compute_constraint_fr compute_constraint_fr_
|
||||
#endif
|
||||
|
||||
#ifdef __cplusplus
|
||||
extern "C"
|
||||
{
|
||||
#endif
|
||||
void f_bssn_rhs_kernel_timing_reset();
|
||||
int f_bssn_rhs_kernel_timing_bucket_count();
|
||||
const double *f_bssn_rhs_kernel_timing_local_seconds();
|
||||
const char *f_bssn_rhs_kernel_timing_label(int);
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_compute_rhs_bssn(int *, double &, double *, double *, double *, // ex,T,X,Y,Z
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Ricci
|
||||
double *, double *, double *, double *, double *, double *, double *, // constraint violation
|
||||
int &, int &, double &, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_compute_rhs_bssn_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R
|
||||
double *, double *, double *, // X,Y,Z
|
||||
double *, double *, double *, // drhodx,drhody,drhodz
|
||||
double *, double *, double *, // dsigmadx,dsigmady,dsigmadz
|
||||
double *, double *, double *, // dRdx,dRdy,dRdz
|
||||
double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz
|
||||
double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz
|
||||
double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Ricci
|
||||
double *, double *, double *, double *, double *, double *, double *, // constraint violation
|
||||
int &, int &, double &, int &, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_compute_rhs_bssn_escalar(int *, double &, double *, double *, double *, // ex,T,X,Y,Z
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, double *, // Sphi, Spi
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, double *, // Sphi, Spi
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Ricci
|
||||
double *, double *, double *, double *, double *, double *, double *, // constraint violation
|
||||
int &, int &, double &, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_compute_rhs_bssn_escalar_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R
|
||||
double *, double *, double *, // X,Y,Z
|
||||
double *, double *, double *, // drhodx,drhody,drhodz
|
||||
double *, double *, double *, // dsigmadx,dsigmady,dsigmadz
|
||||
double *, double *, double *, // dRdx,dRdy,dRdz
|
||||
double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz
|
||||
double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz
|
||||
double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, double *, // Sphi,Spi
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, double *, // Sphi,Spi
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Ricci
|
||||
double *, double *, double *, double *, double *, double *, double *, // constraint violation
|
||||
int &, int &, double &, int &, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_compute_rhs_Z4c(int *, double &, double *, double *, double *, // ex,T,X,Y,Z
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, // Z4
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, // Z4
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *, double *,
|
||||
int &, int &, double &, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_compute_rhs_Z4c_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R
|
||||
double *, double *, double *, // X,Y,Z
|
||||
double *, double *, double *, // drhodx,drhody,drhodz
|
||||
double *, double *, double *, // dsigmadx,dsigmady,dsigmadz
|
||||
double *, double *, double *, // dRdx,dRdy,dRdz
|
||||
double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz
|
||||
double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz
|
||||
double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, // TZ
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, // TZ
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Christoffel
|
||||
double *, double *, double *, double *, double *, double *, // Ricci
|
||||
double *, double *, double *, double *, double *, double *, double *, // constraint violation
|
||||
int &, int &, double &, int &, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_compute_rhs_Z4cnot(int *, double &, double *, double *, double *, // ex,T,X,Y,Z
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, // Z4
|
||||
double *, double *, // chi, trK
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, // Gam
|
||||
double *, double *, double *, double *, double *, double *, double *, // Gauge
|
||||
double *, // Z4
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *, double *,
|
||||
int &, int &, double &, int &, double &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
void f_compute_constraint_fr(int *, double *, double *, double *, // ex,X,Y,Z
|
||||
double *, double *, double *, double *, // chi, trK,rho,Sphi
|
||||
double *, double *, double *, double *, double *, double *, // gij
|
||||
double *, double *, double *, double *, double *, double *, // Aij
|
||||
double *, double *, double *, double *, double *, double *, // Rij
|
||||
double *, double *, double *, double *, double *, double *, // Sij
|
||||
double *);
|
||||
} // FR_cons
|
||||
|
||||
#endif /* BSSN_H */
|
||||
1287
AMSS_NCKU_source/BSSN/bssn_rhs_c.C
Normal file
1287
AMSS_NCKU_source/BSSN/bssn_rhs_c.C
Normal file
File diff suppressed because it is too large
Load Diff
1358
AMSS_NCKU_source/BSSN/bssn_rhs_ss.f90
Normal file
1358
AMSS_NCKU_source/BSSN/bssn_rhs_ss.f90
Normal file
File diff suppressed because it is too large
Load Diff
610
AMSS_NCKU_source/BSSN/empart.f90
Normal file
610
AMSS_NCKU_source/BSSN/empart.f90
Normal file
@@ -0,0 +1,610 @@
|
||||
|
||||
!including advection term in this routine
|
||||
function compute_rhs_empart(ext, X, Y, Z, &
|
||||
chi , dxx , dxy , dxz , dyy , dyz , dzz,&
|
||||
Lap , betax , betay , betaz , trK, &
|
||||
Ex, Ey, Ez, Bx, By, Bz, Kpsi, Kphi,Jx,Jy,Jz,qchar, &
|
||||
Ex_rhs, Ey_rhs, Ez_rhs, Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs, &
|
||||
rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, &
|
||||
Symmetry,Lev,eps) result(gont)
|
||||
implicit none
|
||||
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer,intent(in ):: ext(1:3), Symmetry,Lev
|
||||
real*8, intent(in ):: X(1:ext(1)),Y(1:ext(2)),Z(1:ext(3))
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Jx,Jy,Jz,qchar
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,dxy,dxz,dyy,dyz,dzz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Lap, betax, betay, betaz, trK
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Ex_rhs, Ey_rhs, Ez_rhs
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: rho,Sx,Sy,Sz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Sxx,Sxy,Sxz,Syy,Syz,Szz
|
||||
real*8,intent(in) :: eps
|
||||
! gont = 0: success; gont = 1: something wrong
|
||||
integer::gont
|
||||
|
||||
!~~~~~~> Other variables:
|
||||
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz,gxy,gxz,gyz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: chix,chiy,chiz,chi3o2
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: Lapx,Lapy,Lapz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: betaxx,betaxy,betaxz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: betayx,betayy,betayz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: betazx,betazy,betazz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: alpn1,chin1
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: Exx,Exy,Exz,Eyx,Eyy,Eyz,Ezx,Ezy,Ezz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: Bxx,Bxy,Bxz,Byx,Byy,Byz,Bzx,Bzy,Bzz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: Kpsix,Kpsiy,Kpsiz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: Kphix,Kphiy,Kphiz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: lEx,lEy,lEz,lBx,lBy,lBz
|
||||
|
||||
real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA
|
||||
real*8 :: dX, dY, dZ, PI
|
||||
real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0
|
||||
real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0
|
||||
real*8, parameter :: F3o2=1.5d0,EIT=8.d0
|
||||
real*8,parameter :: kappa = 1.d0
|
||||
!!! sanity check
|
||||
dX = sum(Ex)+sum(Ey)+sum(Ez)+sum(Bx)+sum(By)+sum(Bz)+sum(Kpsi)+sum(Kphi)
|
||||
if(dX.ne.dX) then
|
||||
if(sum(Ex).ne.sum(Ex))write(*,*)"empart.f90: find NaN in Ex"
|
||||
if(sum(Ey).ne.sum(Ey))write(*,*)"empart.f90: find NaN in Ey"
|
||||
if(sum(Ez).ne.sum(Ez))write(*,*)"empart.f90: find NaN in Ez"
|
||||
if(sum(Bx).ne.sum(Bx))write(*,*)"empart.f90: find NaN in Bx"
|
||||
if(sum(By).ne.sum(By))write(*,*)"empart.f90: find NaN in By"
|
||||
if(sum(Bz).ne.sum(Bz))write(*,*)"empart.f90: find NaN in Bz"
|
||||
if(sum(Kpsi).ne.sum(Kpsi))write(*,*)"empart.f90: find NaN in Kpsi"
|
||||
if(sum(Kphi).ne.sum(Kphi))write(*,*)"empart.f90: find NaN in Kphi"
|
||||
gont = 1
|
||||
return
|
||||
endif
|
||||
|
||||
PI = dacos(-ONE)
|
||||
|
||||
dX = X(2) - X(1)
|
||||
dY = Y(2) - Y(1)
|
||||
dZ = Z(2) - Z(1)
|
||||
|
||||
alpn1 = Lap + ONE
|
||||
chin1 = chi + ONE
|
||||
chi3o2 = dsqrt(chin1)**3
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
gxy = dxy
|
||||
gxz = dxz
|
||||
gyz = dyz
|
||||
|
||||
call fderivs(ext,Lap,Lapx,Lapy,Lapz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev)
|
||||
call fderivs(ext,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev)
|
||||
call fderivs(ext,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev)
|
||||
call fderivs(ext,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev)
|
||||
|
||||
call fderivs(ext,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev)
|
||||
|
||||
call fderivs(ext,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev)
|
||||
call fderivs(ext,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev)
|
||||
call fderivs(ext,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,Lev)
|
||||
call fderivs(ext,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev)
|
||||
call fderivs(ext,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,Lev)
|
||||
call fderivs(ext,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev)
|
||||
|
||||
call fderivs(ext,Kpsi,Kpsix,Kpsiy,Kpsiz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev)
|
||||
call fderivs(ext,Kphi,Kphix,Kphiy,Kphiz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev)
|
||||
|
||||
call fderivs(ext,Ex,Exx,Exy,Exz,X,Y,Z,ANTI,SYM,SYM ,Symmetry,Lev)
|
||||
call fderivs(ext,Ey,Eyx,Eyy,Eyz,X,Y,Z,SYM,ANTI,SYM ,Symmetry,Lev)
|
||||
call fderivs(ext,Ez,Ezx,Ezy,Ezz,X,Y,Z,SYM,SYM,ANTI ,Symmetry,Lev)
|
||||
|
||||
call fderivs(ext,Bx,Bxx,Bxy,Bxz,X,Y,Z,SYM,ANTI,ANTI ,Symmetry,Lev)
|
||||
call fderivs(ext,By,Byx,Byy,Byz,X,Y,Z,ANTI,SYM,ANTI ,Symmetry,Lev)
|
||||
call fderivs(ext,Bz,Bzx,Bzy,Bzz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev)
|
||||
|
||||
! physical gij
|
||||
gxx = gxx/chin1
|
||||
gxy = gxy/chin1
|
||||
gxz = gxz/chin1
|
||||
gyy = gyy/chin1
|
||||
gyz = gyz/chin1
|
||||
gzz = gzz/chin1
|
||||
!physical gij,k
|
||||
gxxx = (gxxx-gxx*chix)/chin1
|
||||
gxxy = (gxxy-gxx*chiy)/chin1
|
||||
gxxz = (gxxz-gxx*chiz)/chin1
|
||||
gxyx = (gxyx-gxy*chix)/chin1
|
||||
gxyy = (gxyy-gxy*chiy)/chin1
|
||||
gxyz = (gxyz-gxy*chiz)/chin1
|
||||
gxzx = (gxzx-gxz*chix)/chin1
|
||||
gxzy = (gxzy-gxz*chiy)/chin1
|
||||
gxzz = (gxzz-gxz*chiz)/chin1
|
||||
gyyx = (gyyx-gyy*chix)/chin1
|
||||
gyyy = (gyyy-gyy*chiy)/chin1
|
||||
gyyz = (gyyz-gyy*chiz)/chin1
|
||||
gyzx = (gyzx-gyz*chix)/chin1
|
||||
gyzy = (gyzy-gyz*chiy)/chin1
|
||||
gyzz = (gyzz-gyz*chiz)/chin1
|
||||
gzzx = (gzzx-gzz*chix)/chin1
|
||||
gzzy = (gzzy-gzz*chiy)/chin1
|
||||
gzzz = (gzzz-gzz*chiz)/chin1
|
||||
|
||||
! physical inverse metric
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
Ex_rhs = alpn1*trK*Ex-(Ex*betaxx+Ey*betaxy+Ez*betaxz) &
|
||||
-FOUR*PI*alpn1*Jx-alpn1*(gupxx*Kpsix+gupxy*Kpsiy+gupxz*Kpsiz) &
|
||||
+chi3o2*( &
|
||||
((gxz*Bx+gyz*By+gzz*Bz)*Lapy+alpn1*(gxz*Bxy+gyz*Byy+gzz*Bzy)+alpn1*(Bx*gxzy+By*gyzy+Bz*gzzy))-&
|
||||
((gxy*Bx+gyy*By+gyz*Bz)*Lapz+alpn1*(gxy*Bxz+gyy*Byz+gyz*Bzz)+alpn1*(Bx*gxyz+By*gyyz+Bz*gyzz)))
|
||||
Ey_rhs = alpn1*trK*Ey-(Ex*betayx+Ey*betayy+Ez*betayz) &
|
||||
-FOUR*PI*alpn1*Jy-alpn1*(gupxy*Kpsix+gupyy*Kpsiy+gupyz*Kpsiz) &
|
||||
+chi3o2*( &
|
||||
((gxx*Bx+gxy*By+gxz*Bz)*Lapz+alpn1*(gxx*Bxz+gxy*Byz+gxz*Bzz)+alpn1*(Bx*gxxz+By*gxyz+Bz*gxzz))-&
|
||||
((gxz*Bx+gyz*By+gzz*Bz)*Lapx+alpn1*(gxz*Bxx+gyz*Byx+gzz*Bzx)+alpn1*(Bx*gxzx+By*gyzx+Bz*gzzx)))
|
||||
Ez_rhs = alpn1*trK*Ez-(Ex*betazx+Ey*betazy+Ez*betazz) &
|
||||
-FOUR*PI*alpn1*Jz-alpn1*(gupxz*Kpsix+gupyz*Kpsiy+gupzz*Kpsiz) &
|
||||
+chi3o2*( &
|
||||
((gxy*Bx+gyy*By+gyz*Bz)*Lapx+alpn1*(gxy*Bxx+gyy*Byx+gyz*Bzx)+alpn1*(Bx*gxyx+By*gyyx+Bz*gyzx))-&
|
||||
((gxx*Bx+gxy*By+gxz*Bz)*Lapy+alpn1*(gxx*Bxy+gxy*Byy+gxz*Bzy)+alpn1*(Bx*gxxy+By*gxyy+Bz*gxzy)))
|
||||
|
||||
Bx_rhs = alpn1*trK*Bx-(Bx*betaxx+By*betaxy+Bz*betaxz) &
|
||||
-alpn1*(gupxx*Kphix+gupxy*Kphiy+gupxz*Kphiz) &
|
||||
-chi3o2*( &
|
||||
((gxz*Ex+gyz*Ey+gzz*Ez)*Lapy+alpn1*(gxz*Exy+gyz*Eyy+gzz*Ezy)+alpn1*(Ex*gxzy+Ey*gyzy+Ez*gzzy))-&
|
||||
((gxy*Ex+gyy*Ey+gyz*Ez)*Lapz+alpn1*(gxy*Exz+gyy*Eyz+gyz*Ezz)+alpn1*(Ex*gxyz+Ey*gyyz+Ez*gyzz)))
|
||||
By_rhs = alpn1*trK*By-(Bx*betayx+By*betayy+Bz*betayz) &
|
||||
-alpn1*(gupxy*Kphix+gupyy*Kphiy+gupyz*Kphiz) &
|
||||
-chi3o2*( &
|
||||
((gxx*Ex+gxy*Ey+gxz*Ez)*Lapz+alpn1*(gxx*Exz+gxy*Eyz+gxz*Ezz)+alpn1*(Ex*gxxz+Ey*gxyz+Ez*gxzz))-&
|
||||
((gxz*Ex+gyz*Ey+gzz*Ez)*Lapx+alpn1*(gxz*Exx+gyz*Eyx+gzz*Ezx)+alpn1*(Ex*gxzx+Ey*gyzx+Ez*gzzx)))
|
||||
Bz_rhs = alpn1*trK*Bz-(Bx*betazx+By*betazy+Bz*betazz) &
|
||||
-alpn1*(gupxz*Kphix+gupyz*Kphiy+gupzz*Kphiz) &
|
||||
-chi3o2*( &
|
||||
((gxy*Ex+gyy*Ey+gyz*Ez)*Lapx+alpn1*(gxy*Exx+gyy*Eyx+gyz*Ezx)+alpn1*(Ex*gxyx+Ey*gyyx+Ez*gyzx))-&
|
||||
((gxx*Ex+gxy*Ey+gxz*Ez)*Lapy+alpn1*(gxx*Exy+gxy*Eyy+gxz*Ezy)+alpn1*(Ex*gxxy+Ey*gxyy+Ez*gxzy)))
|
||||
|
||||
Kpsi_rhs = FOUR*PI*alpn1*qchar-alpn1*kappa*Kpsi - &
|
||||
alpn1*(Exx+Eyy+Ezz-F3o2/chin1*(chix*Ex+chiy*Ey+chiz*Ez))
|
||||
Kphi_rhs = -alpn1*kappa*Kphi - &
|
||||
alpn1*(Bxx+Byy+Bzz-F3o2/chin1*(chix*Bx+chiy*By+chiz*Bz))
|
||||
|
||||
SSS(1)=SYM
|
||||
SSS(2)=SYM
|
||||
SSS(3)=SYM
|
||||
|
||||
AAS(1)=ANTI
|
||||
AAS(2)=ANTI
|
||||
AAS(3)=SYM
|
||||
|
||||
ASA(1)=ANTI
|
||||
ASA(2)=SYM
|
||||
ASA(3)=ANTI
|
||||
|
||||
SAA(1)=SYM
|
||||
SAA(2)=ANTI
|
||||
SAA(3)=ANTI
|
||||
|
||||
ASS(1)=ANTI
|
||||
ASS(2)=SYM
|
||||
ASS(3)=SYM
|
||||
|
||||
SAS(1)=SYM
|
||||
SAS(2)=ANTI
|
||||
SAS(3)=SYM
|
||||
|
||||
SSA(1)=SYM
|
||||
SSA(2)=SYM
|
||||
SSA(3)=ANTI
|
||||
|
||||
!!!!!!!!!advection term part
|
||||
call lopsided(ext,X,Y,Z,KPsi,KPsi_rhs,betax,betay,betaz,Symmetry,SSS)
|
||||
call lopsided(ext,X,Y,Z,KPhi,KPhi_rhs,betax,betay,betaz,Symmetry,SSS)
|
||||
|
||||
call lopsided(ext,X,Y,Z,Ex,Ex_rhs,betax,betay,betaz,Symmetry,ASS)
|
||||
call lopsided(ext,X,Y,Z,Ey,Ey_rhs,betax,betay,betaz,Symmetry,SAS)
|
||||
call lopsided(ext,X,Y,Z,Ez,Ez_rhs,betax,betay,betaz,Symmetry,SSA)
|
||||
|
||||
call lopsided(ext,X,Y,Z,Bx,Bx_rhs,betax,betay,betaz,Symmetry,SAA)
|
||||
call lopsided(ext,X,Y,Z,By,By_rhs,betax,betay,betaz,Symmetry,ASA)
|
||||
call lopsided(ext,X,Y,Z,Bz,Bz_rhs,betax,betay,betaz,Symmetry,AAS)
|
||||
|
||||
! numerical dissipation part
|
||||
if(eps>0)then
|
||||
! usual Kreiss-Oliger dissipation
|
||||
|
||||
call kodis(ext,X,Y,Z,Kpsi,Kpsi_rhs,SSS,Symmetry,eps)
|
||||
call kodis(ext,X,Y,Z,Kphi,Kphi_rhs,SSS,Symmetry,eps)
|
||||
call kodis(ext,X,Y,Z,Ex,Ex_rhs,ASS,Symmetry,eps)
|
||||
call kodis(ext,X,Y,Z,Ey,Ey_rhs,SAS,Symmetry,eps)
|
||||
call kodis(ext,X,Y,Z,Ez,Ez_rhs,SSA,Symmetry,eps)
|
||||
call kodis(ext,X,Y,Z,Bx,Bx_rhs,SAA,Symmetry,eps)
|
||||
call kodis(ext,X,Y,Z,By,By_rhs,ASA,Symmetry,eps)
|
||||
call kodis(ext,X,Y,Z,Bz,Bz_rhs,AAS,Symmetry,eps)
|
||||
|
||||
endif
|
||||
! stress-energy tensor
|
||||
rho = (gxx*(Ex*Ex+Bx*Bx)+gyy*(Ey*Ey+By*By)+gzz*(Ez*Ez+Bz*Bz) + &
|
||||
+TWO*(gxy*(Ex*Ey+Bx*By)+gxz*(Ex*Ez+Bx*Bz)+gyz*(Ey*Ez+By*Bz)))/EIT/PI
|
||||
Sx = (Ey*Bz-Ez*By)/FOUR/PI/chi3o2
|
||||
Sy = (Ez*Bx-Ex*Bz)/FOUR/PI/chi3o2
|
||||
Sz = (Ex*By-Ey*Bx)/FOUR/PI/chi3o2
|
||||
lEx = gxx*Ex+gxy*Ey+gxz*Ez
|
||||
lEy = gxy*Ex+gyy*Ey+gyz*Ez
|
||||
lEz = gxz*Ex+gyz*Ey+gzz*Ez
|
||||
lBx = gxx*Bx+gxy*By+gxz*Bz
|
||||
lBy = gxy*Bx+gyy*By+gyz*Bz
|
||||
lBz = gxz*Bx+gyz*By+gzz*Bz
|
||||
Sxx = rho*gxx-(lEx*lEx+lBx*lBx)/FOUR/PI
|
||||
Sxy = rho*gxy-(lEx*lEy+lBx*lBy)/FOUR/PI
|
||||
Sxz = rho*gxz-(lEx*lEz+lBx*lBz)/FOUR/PI
|
||||
Syy = rho*gyy-(lEy*lEy+lBy*lBy)/FOUR/PI
|
||||
Syz = rho*gyz-(lEy*lEz+lBy*lBz)/FOUR/PI
|
||||
Szz = rho*gzz-(lEz*lEz+lBz*lBz)/FOUR/PI
|
||||
|
||||
gont = 0
|
||||
|
||||
return
|
||||
|
||||
end function compute_rhs_empart
|
||||
!including advection term in this routine
|
||||
! for shell
|
||||
function compute_rhs_empart_ss(ext,crho,sigma,R,x,y,z, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz, &
|
||||
drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, &
|
||||
dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, &
|
||||
dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, &
|
||||
chi , dxx , dxy , dxz , dyy , dyz , dzz,&
|
||||
Lap , betax , betay , betaz , trK, &
|
||||
Ex, Ey, Ez, Bx, By, Bz, Kpsi, Kphi,Jx,Jy,Jz,qchar, &
|
||||
Ex_rhs, Ey_rhs, Ez_rhs, Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs, &
|
||||
rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, &
|
||||
Symmetry,Lev,eps,sst) result(gont)
|
||||
implicit none
|
||||
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer,intent(in ):: ext(1:3), Symmetry,Lev,sst
|
||||
double precision,intent(in),dimension(ext(1))::crho
|
||||
double precision,intent(in),dimension(ext(2))::sigma
|
||||
double precision,intent(in),dimension(ext(3))::R
|
||||
double precision,intent(in),dimension(ext(1),ext(2),ext(3))::x,y,z
|
||||
double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodx, drhody, drhodz
|
||||
double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadx,dsigmady,dsigmadz
|
||||
double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdx,dRdy,dRdz
|
||||
double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz
|
||||
double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz
|
||||
double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Jx,Jy,Jz,qchar
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,dxy,dxz,dyy,dyz,dzz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Lap, betax, betay, betaz, trK
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Ex_rhs, Ey_rhs, Ez_rhs
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: rho,Sx,Sy,Sz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Sxx,Sxy,Sxz,Syy,Syz,Szz
|
||||
real*8,intent(in) :: eps
|
||||
! gont = 0: success; gont = 1: something wrong
|
||||
integer::gont
|
||||
|
||||
!~~~~~~> Other variables:
|
||||
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz,gxy,gxz,gyz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: chix,chiy,chiz,chi3o2
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: Lapx,Lapy,Lapz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: betaxx,betaxy,betaxz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: betayx,betayy,betayz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: betazx,betazy,betazz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: alpn1,chin1
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: Exx,Exy,Exz,Eyx,Eyy,Eyz,Ezx,Ezy,Ezz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: Bxx,Bxy,Bxz,Byx,Byy,Byz,Bzx,Bzy,Bzz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: Kpsix,Kpsiy,Kpsiz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: Kphix,Kphiy,Kphiz
|
||||
real*8, dimension(ext(1),ext(2),ext(3)) :: lEx,lEy,lEz,lBx,lBy,lBz
|
||||
|
||||
real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA
|
||||
real*8 :: dX, dY, dZ, PI
|
||||
real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0
|
||||
real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0
|
||||
real*8, parameter :: F3o2=1.5d0,EIT=8.d0
|
||||
real*8,parameter :: kappa = 1.d0
|
||||
|
||||
!!! sanity check
|
||||
dX = sum(Ex)+sum(Ey)+sum(Ez)+sum(Bx)+sum(By)+sum(Bz)+sum(Kpsi)+sum(Kphi)
|
||||
if(dX.ne.dX) then
|
||||
if(sum(Ex).ne.sum(Ex))write(*,*)"empart.f90: find NaN in Ex"
|
||||
if(sum(Ey).ne.sum(Ey))write(*,*)"empart.f90: find NaN in Ey"
|
||||
if(sum(Ez).ne.sum(Ez))write(*,*)"empart.f90: find NaN in Ez"
|
||||
if(sum(Bx).ne.sum(Bx))write(*,*)"empart.f90: find NaN in Bx"
|
||||
if(sum(By).ne.sum(By))write(*,*)"empart.f90: find NaN in By"
|
||||
if(sum(Bz).ne.sum(Bz))write(*,*)"empart.f90: find NaN in Bz"
|
||||
if(sum(Kpsi).ne.sum(Kpsi))write(*,*)"empart.f90: find NaN in Kpsi"
|
||||
if(sum(Kphi).ne.sum(Kphi))write(*,*)"empart.f90: find NaN in Kphi"
|
||||
gont = 1
|
||||
return
|
||||
endif
|
||||
|
||||
PI = dacos(-ONE)
|
||||
|
||||
dX = crho(2) - crho(1)
|
||||
dY = sigma(2) - sigma(1)
|
||||
dZ = R(2) - R(1)
|
||||
|
||||
alpn1 = Lap + ONE
|
||||
chin1 = chi + ONE
|
||||
chi3o2 = dsqrt(chin1)**3
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
gxy = dxy
|
||||
gxz = dxz
|
||||
gyz = dyz
|
||||
|
||||
call fderivs_shc(ext,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
call fderivs_shc(ext,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
call fderivs_shc(ext,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
call fderivs_shc(ext,Kpsi,Kpsix,Kpsiy,Kpsiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,Kphi,Kphix,Kphiy,Kphiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
call fderivs_shc(ext,Ex,Exx,Exy,Exz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,Ey,Eyx,Eyy,Eyz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,Ez,Ezx,Ezy,Ezz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
#if 1
|
||||
call fderivs_shc(ext,Bx,Bxx,Bxy,Bxz,crho,sigma,R, SYM,ANTI,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,By,Byx,Byy,Byz,crho,sigma,R,ANTI, SYM,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,Bz,Bzx,Bzy,Bzz,crho,sigma,R,ANTI,ANTI, SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
#else
|
||||
call fderivs_shc(ext,Bx,Bxx,Bxy,Bxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,By,Byx,Byy,Byz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
call fderivs_shc(ext,Bz,Bzx,Bzy,Bzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
#endif
|
||||
! check axal vector
|
||||
! physical gij
|
||||
gxx = gxx/chin1
|
||||
gxy = gxy/chin1
|
||||
gxz = gxz/chin1
|
||||
gyy = gyy/chin1
|
||||
gyz = gyz/chin1
|
||||
gzz = gzz/chin1
|
||||
!physical gij,k
|
||||
gxxx = (gxxx-gxx*chix)/chin1
|
||||
gxxy = (gxxy-gxx*chiy)/chin1
|
||||
gxxz = (gxxz-gxx*chiz)/chin1
|
||||
gxyx = (gxyx-gxy*chix)/chin1
|
||||
gxyy = (gxyy-gxy*chiy)/chin1
|
||||
gxyz = (gxyz-gxy*chiz)/chin1
|
||||
gxzx = (gxzx-gxz*chix)/chin1
|
||||
gxzy = (gxzy-gxz*chiy)/chin1
|
||||
gxzz = (gxzz-gxz*chiz)/chin1
|
||||
gyyx = (gyyx-gyy*chix)/chin1
|
||||
gyyy = (gyyy-gyy*chiy)/chin1
|
||||
gyyz = (gyyz-gyy*chiz)/chin1
|
||||
gyzx = (gyzx-gyz*chix)/chin1
|
||||
gyzy = (gyzy-gyz*chiy)/chin1
|
||||
gyzz = (gyzz-gyz*chiz)/chin1
|
||||
gzzx = (gzzx-gzz*chix)/chin1
|
||||
gzzy = (gzzy-gzz*chiy)/chin1
|
||||
gzzz = (gzzz-gzz*chiz)/chin1
|
||||
|
||||
! physical inverse metric
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
Ex_rhs = alpn1*trK*Ex-(Ex*betaxx+Ey*betaxy+Ez*betaxz) &
|
||||
-FOUR*PI*alpn1*Jx-alpn1*(gupxx*Kpsix+gupxy*Kpsiy+gupxz*Kpsiz) &
|
||||
+chi3o2*( &
|
||||
((gxz*Bx+gyz*By+gzz*Bz)*Lapy+alpn1*(gxz*Bxy+gyz*Byy+gzz*Bzy)+alpn1*(Bx*gxzy+By*gyzy+Bz*gzzy))-&
|
||||
((gxy*Bx+gyy*By+gyz*Bz)*Lapz+alpn1*(gxy*Bxz+gyy*Byz+gyz*Bzz)+alpn1*(Bx*gxyz+By*gyyz+Bz*gyzz)))
|
||||
Ey_rhs = alpn1*trK*Ey-(Ex*betayx+Ey*betayy+Ez*betayz) &
|
||||
-FOUR*PI*alpn1*Jy-alpn1*(gupxy*Kpsix+gupyy*Kpsiy+gupyz*Kpsiz) &
|
||||
+chi3o2*( &
|
||||
((gxx*Bx+gxy*By+gxz*Bz)*Lapz+alpn1*(gxx*Bxz+gxy*Byz+gxz*Bzz)+alpn1*(Bx*gxxz+By*gxyz+Bz*gxzz))-&
|
||||
((gxz*Bx+gyz*By+gzz*Bz)*Lapx+alpn1*(gxz*Bxx+gyz*Byx+gzz*Bzx)+alpn1*(Bx*gxzx+By*gyzx+Bz*gzzx)))
|
||||
Ez_rhs = alpn1*trK*Ez-(Ex*betazx+Ey*betazy+Ez*betazz) &
|
||||
-FOUR*PI*alpn1*Jz-alpn1*(gupxz*Kpsix+gupyz*Kpsiy+gupzz*Kpsiz) &
|
||||
+chi3o2*( &
|
||||
((gxy*Bx+gyy*By+gyz*Bz)*Lapx+alpn1*(gxy*Bxx+gyy*Byx+gyz*Bzx)+alpn1*(Bx*gxyx+By*gyyx+Bz*gyzx))-&
|
||||
((gxx*Bx+gxy*By+gxz*Bz)*Lapy+alpn1*(gxx*Bxy+gxy*Byy+gxz*Bzy)+alpn1*(Bx*gxxy+By*gxyy+Bz*gxzy)))
|
||||
|
||||
Bx_rhs = alpn1*trK*Bx-(Bx*betaxx+By*betaxy+Bz*betaxz) &
|
||||
-alpn1*(gupxx*Kphix+gupxy*Kphiy+gupxz*Kphiz) &
|
||||
-chi3o2*( &
|
||||
((gxz*Ex+gyz*Ey+gzz*Ez)*Lapy+alpn1*(gxz*Exy+gyz*Eyy+gzz*Ezy)+alpn1*(Ex*gxzy+Ey*gyzy+Ez*gzzy))-&
|
||||
((gxy*Ex+gyy*Ey+gyz*Ez)*Lapz+alpn1*(gxy*Exz+gyy*Eyz+gyz*Ezz)+alpn1*(Ex*gxyz+Ey*gyyz+Ez*gyzz)))
|
||||
By_rhs = alpn1*trK*By-(Bx*betayx+By*betayy+Bz*betayz) &
|
||||
-alpn1*(gupxy*Kphix+gupyy*Kphiy+gupyz*Kphiz) &
|
||||
-chi3o2*( &
|
||||
((gxx*Ex+gxy*Ey+gxz*Ez)*Lapz+alpn1*(gxx*Exz+gxy*Eyz+gxz*Ezz)+alpn1*(Ex*gxxz+Ey*gxyz+Ez*gxzz))-&
|
||||
((gxz*Ex+gyz*Ey+gzz*Ez)*Lapx+alpn1*(gxz*Exx+gyz*Eyx+gzz*Ezx)+alpn1*(Ex*gxzx+Ey*gyzx+Ez*gzzx)))
|
||||
Bz_rhs = alpn1*trK*Bz-(Bx*betazx+By*betazy+Bz*betazz) &
|
||||
-alpn1*(gupxz*Kphix+gupyz*Kphiy+gupzz*Kphiz) &
|
||||
-chi3o2*( &
|
||||
((gxy*Ex+gyy*Ey+gyz*Ez)*Lapx+alpn1*(gxy*Exx+gyy*Eyx+gyz*Ezx)+alpn1*(Ex*gxyx+Ey*gyyx+Ez*gyzx))-&
|
||||
((gxx*Ex+gxy*Ey+gxz*Ez)*Lapy+alpn1*(gxx*Exy+gxy*Eyy+gxz*Ezy)+alpn1*(Ex*gxxy+Ey*gxyy+Ez*gxzy)))
|
||||
|
||||
Kpsi_rhs = FOUR*PI*alpn1*qchar-alpn1*kappa*Kpsi - &
|
||||
alpn1*(Exx+Eyy+Ezz-F3o2/chin1*(chix*Ex+chiy*Ey+chiz*Ez))
|
||||
Kphi_rhs = -alpn1*kappa*Kphi - &
|
||||
alpn1*(Bxx+Byy+Bzz-F3o2/chin1*(chix*Bx+chiy*By+chiz*Bz))
|
||||
|
||||
SSS(1)=SYM
|
||||
SSS(2)=SYM
|
||||
SSS(3)=SYM
|
||||
|
||||
AAS(1)=ANTI
|
||||
AAS(2)=ANTI
|
||||
AAS(3)=SYM
|
||||
|
||||
ASA(1)=ANTI
|
||||
ASA(2)=SYM
|
||||
ASA(3)=ANTI
|
||||
|
||||
SAA(1)=SYM
|
||||
SAA(2)=ANTI
|
||||
SAA(3)=ANTI
|
||||
|
||||
ASS(1)=ANTI
|
||||
ASS(2)=SYM
|
||||
ASS(3)=SYM
|
||||
|
||||
SAS(1)=SYM
|
||||
SAS(2)=ANTI
|
||||
SAS(3)=SYM
|
||||
|
||||
SSA(1)=SYM
|
||||
SSA(2)=SYM
|
||||
SSA(3)=ANTI
|
||||
|
||||
!!!!!!!!!advection term part
|
||||
Kpsi_rhs = Kpsi_rhs + betax*Kpsix+betay*Kpsiy+betaz*Kpsiz
|
||||
Kphi_rhs = Kphi_rhs + betax*Kphix+betay*Kphiy+betaz*Kphiz
|
||||
|
||||
Ex_rhs = Ex_rhs + betax*Exx+betay*Exy+betaz*Exz
|
||||
Ey_rhs = Ey_rhs + betax*Eyx+betay*Eyy+betaz*Eyz
|
||||
Ez_rhs = Ez_rhs + betax*Ezx+betay*Ezy+betaz*Ezz
|
||||
|
||||
Bx_rhs = Bx_rhs + betax*Bxx+betay*Bxy+betaz*Bxz
|
||||
By_rhs = By_rhs + betax*Byx+betay*Byy+betaz*Byz
|
||||
Bz_rhs = Bz_rhs + betax*Bzx+betay*Bzy+betaz*Bzz
|
||||
|
||||
! numerical dissipation part
|
||||
if(eps>0)then
|
||||
! usual Kreiss-Oliger dissipation
|
||||
|
||||
call kodis_sh(ext,crho,sigma,R,Kpsi,Kpsi_rhs,SSS,Symmetry,eps,sst)
|
||||
call kodis_sh(ext,crho,sigma,R,Kphi,Kphi_rhs,SSS,Symmetry,eps,sst)
|
||||
call kodis_sh(ext,crho,sigma,R,Ex,Ex_rhs,ASS,Symmetry,eps,sst)
|
||||
call kodis_sh(ext,crho,sigma,R,Ey,Ey_rhs,SAS,Symmetry,eps,sst)
|
||||
call kodis_sh(ext,crho,sigma,R,Ez,Ez_rhs,SSA,Symmetry,eps,sst)
|
||||
call kodis_sh(ext,crho,sigma,R,Bx,Bx_rhs,SAA,Symmetry,eps,sst)
|
||||
call kodis_sh(ext,crho,sigma,R,By,By_rhs,ASA,Symmetry,eps,sst)
|
||||
call kodis_sh(ext,crho,sigma,R,Bz,Bz_rhs,AAS,Symmetry,eps,sst)
|
||||
|
||||
endif
|
||||
! stress-energy tensor
|
||||
rho = (gxx*(Ex*Ex+Bx*Bx)+gyy*(Ey*Ey+By*By)+gzz*(Ez*Ez+Bz*Bz) + &
|
||||
+TWO*(gxy*(Ex*Ey+Bx*By)+gxz*(Ex*Ez+Bx*Bz)+gyz*(Ey*Ez+By*Bz)))/EIT/PI
|
||||
Sx = (Ey*Bz-Ez*By)/FOUR/PI/chi3o2
|
||||
Sy = (Ez*Bx-Ex*Bz)/FOUR/PI/chi3o2
|
||||
Sz = (Ex*By-Ey*Bx)/FOUR/PI/chi3o2
|
||||
lEx = gxx*Ex+gxy*Ey+gxz*Ez
|
||||
lEy = gxy*Ex+gyy*Ey+gyz*Ez
|
||||
lEz = gxz*Ex+gyz*Ey+gzz*Ez
|
||||
lBx = gxx*Bx+gxy*By+gxz*Bz
|
||||
lBy = gxy*Bx+gyy*By+gyz*Bz
|
||||
lBz = gxz*Bx+gyz*By+gzz*Bz
|
||||
Sxx = rho*gxx-(lEx*lEx+lBx*lBx)/FOUR/PI
|
||||
Sxy = rho*gxy-(lEx*lEy+lBx*lBy)/FOUR/PI
|
||||
Sxz = rho*gxz-(lEx*lEz+lBx*lBz)/FOUR/PI
|
||||
Syy = rho*gyy-(lEy*lEy+lBy*lBy)/FOUR/PI
|
||||
Syz = rho*gyz-(lEy*lEz+lBy*lBz)/FOUR/PI
|
||||
Szz = rho*gzz-(lEz*lEz+lBz*lBz)/FOUR/PI
|
||||
|
||||
gont = 0
|
||||
|
||||
return
|
||||
|
||||
end function compute_rhs_empart_ss
|
||||
45
AMSS_NCKU_source/BSSN/empart.h
Normal file
45
AMSS_NCKU_source/BSSN/empart.h
Normal file
@@ -0,0 +1,45 @@
|
||||
|
||||
#ifndef EMPART_H
|
||||
#define EMPART_H
|
||||
|
||||
#ifdef fortran1
|
||||
#define f_compute_rhs_empart compute_rhs_empart
|
||||
#define f_compute_rhs_empart_ss compute_rhs_empart_ss
|
||||
#endif
|
||||
#ifdef fortran2
|
||||
#define f_compute_rhs_empart COMPUTE_RHS_EMPART
|
||||
#define f_compute_rhs_empart_ss COMPUTE_RHS_EMPART_SS
|
||||
#endif
|
||||
#ifdef fortran3
|
||||
#define f_compute_rhs_empart compute_rhs_empart_
|
||||
#define f_compute_rhs_empart_ss compute_rhs_empart_ss_
|
||||
#endif
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_compute_rhs_empart(int *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *,
|
||||
int &, int &, double &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_compute_rhs_empart_ss(int *, double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *, double *, double *, double *, double *,
|
||||
int &, int &, double &, int &);
|
||||
}
|
||||
#endif /* EMPART_H */
|
||||
230
AMSS_NCKU_source/BSSN/enforce_algebra.f90
Normal file
230
AMSS_NCKU_source/BSSN/enforce_algebra.f90
Normal file
@@ -0,0 +1,230 @@
|
||||
|
||||
!-----------------------------------------------------------------------------
|
||||
!
|
||||
! remove the trace of Aij
|
||||
! trace-free Aij and enforce the determinant of bssn metric to one
|
||||
!-----------------------------------------------------------------------------
|
||||
|
||||
subroutine enforce_ag(ex, dxx, gxy, gxz, dyy, gyz, dzz, &
|
||||
Axx, Axy, Axz, Ayy, Ayz, Azz)
|
||||
implicit none
|
||||
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer, intent(in) :: ex(1:3)
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,dyy,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: gxy,gxz,gyz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Ayy,Ayz,Azz
|
||||
|
||||
!~~~~~~~> Local variable:
|
||||
|
||||
integer :: i,j,k
|
||||
real*8 :: lgxx,lgyy,lgzz,ldetg
|
||||
real*8 :: lgupxx,lgupxy,lgupxz,lgupyy,lgupyz,lgupzz
|
||||
real*8 :: ltrA,lscale
|
||||
real*8, parameter :: F1o3 = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0
|
||||
|
||||
!~~~~~~>
|
||||
|
||||
do k=1,ex(3)
|
||||
do j=1,ex(2)
|
||||
do i=1,ex(1)
|
||||
|
||||
lgxx = dxx(i,j,k) + ONE
|
||||
lgyy = dyy(i,j,k) + ONE
|
||||
lgzz = dzz(i,j,k) + ONE
|
||||
|
||||
ldetg = lgxx * lgyy * lgzz &
|
||||
+ gxy(i,j,k) * gyz(i,j,k) * gxz(i,j,k) &
|
||||
+ gxz(i,j,k) * gxy(i,j,k) * gyz(i,j,k) &
|
||||
- gxz(i,j,k) * lgyy * gxz(i,j,k) &
|
||||
- gxy(i,j,k) * gxy(i,j,k) * lgzz &
|
||||
- lgxx * gyz(i,j,k) * gyz(i,j,k)
|
||||
|
||||
lgupxx = ( lgyy * lgzz - gyz(i,j,k) * gyz(i,j,k) ) / ldetg
|
||||
lgupxy = - ( gxy(i,j,k) * lgzz - gyz(i,j,k) * gxz(i,j,k) ) / ldetg
|
||||
lgupxz = ( gxy(i,j,k) * gyz(i,j,k) - lgyy * gxz(i,j,k) ) / ldetg
|
||||
lgupyy = ( lgxx * lgzz - gxz(i,j,k) * gxz(i,j,k) ) / ldetg
|
||||
lgupyz = - ( lgxx * gyz(i,j,k) - gxy(i,j,k) * gxz(i,j,k) ) / ldetg
|
||||
lgupzz = ( lgxx * lgyy - gxy(i,j,k) * gxy(i,j,k) ) / ldetg
|
||||
|
||||
ltrA = lgupxx * Axx(i,j,k) + lgupyy * Ayy(i,j,k) &
|
||||
+ lgupzz * Azz(i,j,k) &
|
||||
+ TWO * (lgupxy * Axy(i,j,k) + lgupxz * Axz(i,j,k) &
|
||||
+ lgupyz * Ayz(i,j,k))
|
||||
|
||||
Axx(i,j,k) = Axx(i,j,k) - F1o3 * lgxx * ltrA
|
||||
Axy(i,j,k) = Axy(i,j,k) - F1o3 * gxy(i,j,k) * ltrA
|
||||
Axz(i,j,k) = Axz(i,j,k) - F1o3 * gxz(i,j,k) * ltrA
|
||||
Ayy(i,j,k) = Ayy(i,j,k) - F1o3 * lgyy * ltrA
|
||||
Ayz(i,j,k) = Ayz(i,j,k) - F1o3 * gyz(i,j,k) * ltrA
|
||||
Azz(i,j,k) = Azz(i,j,k) - F1o3 * lgzz * ltrA
|
||||
|
||||
lscale = ONE / ( ldetg ** F1o3 )
|
||||
|
||||
dxx(i,j,k) = lgxx * lscale - ONE
|
||||
gxy(i,j,k) = gxy(i,j,k) * lscale
|
||||
gxz(i,j,k) = gxz(i,j,k) * lscale
|
||||
dyy(i,j,k) = lgyy * lscale - ONE
|
||||
gyz(i,j,k) = gyz(i,j,k) * lscale
|
||||
dzz(i,j,k) = lgzz * lscale - ONE
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
return
|
||||
|
||||
end subroutine enforce_ag
|
||||
#if 1
|
||||
!----------------------------------------------------------------------------------
|
||||
! swap the turn of a and g
|
||||
!----------------------------------------------------------------------------------
|
||||
subroutine enforce_ga(ex, dxx, gxy, gxz, dyy, gyz, dzz, &
|
||||
Axx, Axy, Axz, Ayy, Ayz, Azz)
|
||||
implicit none
|
||||
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer, intent(in) :: ex(1:3)
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,dyy,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: gxy,gxz,gyz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Ayy,Ayz,Azz
|
||||
|
||||
!~~~~~~~> Local variable:
|
||||
|
||||
integer :: i,j,k
|
||||
real*8 :: lgxx,lgyy,lgzz,lscale
|
||||
real*8 :: lgxy,lgxz,lgyz
|
||||
real*8 :: lgupxx,lgupxy,lgupxz,lgupyy,lgupyz,lgupzz
|
||||
real*8 :: ltrA
|
||||
real*8, parameter :: F1o3 = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0
|
||||
|
||||
!~~~~~~>
|
||||
|
||||
do k=1,ex(3)
|
||||
do j=1,ex(2)
|
||||
do i=1,ex(1)
|
||||
|
||||
! for g: normalize determinant first
|
||||
lgxx = dxx(i,j,k) + ONE
|
||||
lgyy = dyy(i,j,k) + ONE
|
||||
lgzz = dzz(i,j,k) + ONE
|
||||
lgxy = gxy(i,j,k)
|
||||
lgxz = gxz(i,j,k)
|
||||
lgyz = gyz(i,j,k)
|
||||
|
||||
lscale = lgxx * lgyy * lgzz + lgxy * lgyz * lgxz &
|
||||
+ lgxz * lgxy * lgyz - lgxz * lgyy * lgxz &
|
||||
- lgxy * lgxy * lgzz - lgxx * lgyz * lgyz
|
||||
|
||||
lscale = ONE / ( lscale ** F1o3 )
|
||||
|
||||
lgxx = lgxx * lscale
|
||||
lgxy = lgxy * lscale
|
||||
lgxz = lgxz * lscale
|
||||
lgyy = lgyy * lscale
|
||||
lgyz = lgyz * lscale
|
||||
lgzz = lgzz * lscale
|
||||
|
||||
dxx(i,j,k) = lgxx - ONE
|
||||
gxy(i,j,k) = lgxy
|
||||
gxz(i,j,k) = lgxz
|
||||
dyy(i,j,k) = lgyy - ONE
|
||||
gyz(i,j,k) = lgyz
|
||||
dzz(i,j,k) = lgzz - ONE
|
||||
|
||||
! for A: trace-free using normalized metric (det=1, no division needed)
|
||||
lgupxx = ( lgyy * lgzz - lgyz * lgyz )
|
||||
lgupxy = - ( lgxy * lgzz - lgyz * lgxz )
|
||||
lgupxz = ( lgxy * lgyz - lgyy * lgxz )
|
||||
lgupyy = ( lgxx * lgzz - lgxz * lgxz )
|
||||
lgupyz = - ( lgxx * lgyz - lgxy * lgxz )
|
||||
lgupzz = ( lgxx * lgyy - lgxy * lgxy )
|
||||
|
||||
ltrA = lgupxx * Axx(i,j,k) + lgupyy * Ayy(i,j,k) &
|
||||
+ lgupzz * Azz(i,j,k) &
|
||||
+ TWO * (lgupxy * Axy(i,j,k) + lgupxz * Axz(i,j,k) &
|
||||
+ lgupyz * Ayz(i,j,k))
|
||||
|
||||
Axx(i,j,k) = Axx(i,j,k) - F1o3 * lgxx * ltrA
|
||||
Axy(i,j,k) = Axy(i,j,k) - F1o3 * lgxy * ltrA
|
||||
Axz(i,j,k) = Axz(i,j,k) - F1o3 * lgxz * ltrA
|
||||
Ayy(i,j,k) = Ayy(i,j,k) - F1o3 * lgyy * ltrA
|
||||
Ayz(i,j,k) = Ayz(i,j,k) - F1o3 * lgyz * ltrA
|
||||
Azz(i,j,k) = Azz(i,j,k) - F1o3 * lgzz * ltrA
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
|
||||
return
|
||||
|
||||
end subroutine enforce_ga
|
||||
#else
|
||||
!----------------------------------------------------------------------------------
|
||||
! duplicate bam
|
||||
!----------------------------------------------------------------------------------
|
||||
subroutine enforce_ga(ex, dxx, gxy, gxz, dyy, gyz, dzz, &
|
||||
Axx, Axy, Axz, Ayy, Ayz, Azz)
|
||||
implicit none
|
||||
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer, intent(in) :: ex(1:3)
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,dyy,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: gxy,gxz,gyz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Ayy,Ayz,Azz
|
||||
|
||||
!~~~~~~~> Local variable:
|
||||
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: trA
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: aux,detginv
|
||||
real*8, parameter :: oot = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0
|
||||
|
||||
!~~~~~~>
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
! for g
|
||||
aux = (2.d0*gxy*gxz*gyz + gxx*gyy*gzz &
|
||||
- gzz*gxy**2 - gyy*gxz**2 - gxx*gyz**2)**(-oot)
|
||||
|
||||
gxx = gxx * aux
|
||||
gxy = gxy * aux
|
||||
gxz = gxz * aux
|
||||
gyy = gyy * aux
|
||||
gyz = gyz * aux
|
||||
gzz = gzz * aux
|
||||
|
||||
dxx = gxx - ONE
|
||||
dyy = gyy - ONE
|
||||
dzz = gzz - ONE
|
||||
! for A
|
||||
|
||||
detginv = 1/(2.d0*gxy*gxz*gyz + gxx*gyy*gzz &
|
||||
- gzz*gxy**2 - gyy*gxz**2 - gxx*gyz**2)
|
||||
|
||||
trA = detginv*(-2.d0*Ayz*gxx*gyz + Axx*gyy*gzz + &
|
||||
gxx*(Azz*gyy + Ayy*gzz) + 2.d0*(gxz*(Ayz*gxy - Axz*gyy + &
|
||||
Axy*gyz) + gxy*(Axz*gyz - Axy*gzz)) - Azz*gxy**2 - Ayy*gxz**2 - &
|
||||
Axx*gyz**2)
|
||||
|
||||
aux = -(oot*trA)
|
||||
|
||||
Axx = Axx + aux * gxx
|
||||
Axy = Axy + aux * gxy
|
||||
Axz = Axz + aux * gxz
|
||||
Ayy = Ayy + aux * gyy
|
||||
Ayz = Ayz + aux * gyz
|
||||
Azz = Azz + aux * gzz
|
||||
|
||||
return
|
||||
|
||||
end subroutine enforce_ga
|
||||
#endif
|
||||
30
AMSS_NCKU_source/BSSN/enforce_algebra.h
Normal file
30
AMSS_NCKU_source/BSSN/enforce_algebra.h
Normal file
@@ -0,0 +1,30 @@
|
||||
|
||||
#ifndef ENFORCE_ALGEBRA_H
|
||||
#define ENFORCE_ALGEBRA_H
|
||||
|
||||
#ifdef fortran1
|
||||
#define f_enforce_ag enforce_ag
|
||||
#define f_enforce_ga enforce_ga
|
||||
#endif
|
||||
#ifdef fortran2
|
||||
#define f_enforce_ag ENFORCE_AG
|
||||
#define f_enforce_ga ENFORCE_GA
|
||||
#endif
|
||||
#ifdef fortran3
|
||||
#define f_enforce_ag enforce_ag_
|
||||
#define f_enforce_ga enforce_ga_
|
||||
#endif
|
||||
|
||||
extern "C"
|
||||
{
|
||||
void f_enforce_ag(int *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *);
|
||||
}
|
||||
extern "C"
|
||||
{
|
||||
void f_enforce_ga(int *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *);
|
||||
}
|
||||
#endif /* ENFORCE_ALGEBRA_H */
|
||||
245
AMSS_NCKU_source/BSSN/fadmquantites_bssn.f90
Normal file
245
AMSS_NCKU_source/BSSN/fadmquantites_bssn.f90
Normal file
@@ -0,0 +1,245 @@
|
||||
|
||||
!-----------------------------------------------------------------------------
|
||||
! ADM quantites for surface intergral
|
||||
!-----------------------------------------------------------------------------
|
||||
subroutine admmass_bssn(ex, X, Y, Z, &
|
||||
chi , trK, &
|
||||
dxx , gxy , gxz , dyy , gyz , dzz , &
|
||||
Axx , Axy , Axz , Ayy , Ayz , Azz , &
|
||||
Gamx , Gamy , Gamz , &
|
||||
massx,massy,massz, symmetry)
|
||||
|
||||
implicit none
|
||||
!~~~~~~= Input parameters:
|
||||
|
||||
integer,intent(in) :: ex(1:3),symmetry
|
||||
real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3))
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: massx,massy,massz
|
||||
! local variables
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz
|
||||
! inverse metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz
|
||||
! partial derivative of chi, chi_i
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: f
|
||||
real*8 :: PI, F1o2pi
|
||||
real*8, parameter :: ONE = 1.d0, F1o8 = 1.d0/8.d0
|
||||
real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0
|
||||
real*8 :: dX, dY, dZ
|
||||
|
||||
dX = X(2) - X(1)
|
||||
dY = Y(2) - Y(1)
|
||||
dZ = Z(2) - Z(1)
|
||||
|
||||
PI = dacos( - ONE )
|
||||
F1o2pi = ONE / ( 2.d0 * PI )
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,Symmetry,0)
|
||||
|
||||
f=1/4.d0/(chi+ONE)**1.25d0
|
||||
! mass_i = (Gami/8 + gupij*phi_j/(4*chi^1.25))/(2*Pi)
|
||||
massx = (F1o8*Gamx + f*(gupxx*chix+gupxy*chiy+gupxz*chiz))*F1o2pi
|
||||
massy = (F1o8*Gamy + f*(gupxy*chix+gupyy*chiy+gupyz*chiz))*F1o2pi
|
||||
massz = (F1o8*Gamz + f*(gupxz*chix+gupyz*chiy+gupzz*chiz))*F1o2pi
|
||||
|
||||
return
|
||||
|
||||
end subroutine admmass_bssn
|
||||
!-----------------------------------------------------------------------------------------------
|
||||
! P^i = int r^j p_ji
|
||||
!-----------------------------------------------------------------------------------------------
|
||||
subroutine admmomentum_bssn(ex, &
|
||||
chi, trK, &
|
||||
dxx , gxy , gxz , dyy , gyz , dzz , &
|
||||
Axx , Axy , Axz , Ayy , Ayz , Azz , &
|
||||
Gamx , Gamy , Gamz , &
|
||||
pxx,pxy,pxz,pyy,pyz,pzz)
|
||||
|
||||
implicit none
|
||||
!~~~~~~= Input parameters:
|
||||
|
||||
integer,intent(in) :: ex(1:3)
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: pxx,pxy,pxz,pyy,pyz,pzz
|
||||
! local variables
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,chim4
|
||||
real*8 :: PI, F1o8pi
|
||||
real*8, parameter :: ONE = 1.d0, F1o3 = 1.d0/3.d0
|
||||
|
||||
PI = acos( - ONE )
|
||||
F1o8pi = ONE / ( 8.d0 * PI )
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
|
||||
chim4=1.d0/(chi+ONE)**4
|
||||
Kxx = chim4*(Axx+F1o3*gxx*trK)
|
||||
Kxy = chim4*(Axy+F1o3*gxy*trK)
|
||||
Kxz = chim4*(Axz+F1o3*gxz*trK)
|
||||
Kyy = chim4*(Ayy+F1o3*gyy*trK)
|
||||
Kyz = chim4*(Ayz+F1o3*gyz*trK)
|
||||
Kzz = chim4*(Azz+F1o3*gzz*trK)
|
||||
|
||||
pxx = (Kxx-trK)*F1o8pi
|
||||
pxy = (Kxy )*F1o8pi
|
||||
pxz = (Kxz )*F1o8pi
|
||||
pyy = (Kyy-trK)*F1o8pi
|
||||
pyz = (Kyz )*F1o8pi
|
||||
pzz = (Kzz-trK)*F1o8pi
|
||||
|
||||
return
|
||||
|
||||
end subroutine admmomentum_bssn
|
||||
!-----------------------------------------------------------------------------------------------
|
||||
! S^i = int r^j s_ji
|
||||
!-----------------------------------------------------------------------------------------------
|
||||
subroutine admangularmomentum_bssn(ex,X,Y,Z,&
|
||||
pxx,pxy,pxz,pyy,pyz,pzz, &
|
||||
sxx,sxy,sxz,syx,syy,syz,szx,szy,szz)
|
||||
|
||||
implicit none
|
||||
!~~~~~~= Input parameters:
|
||||
|
||||
integer,intent(in) :: ex(1:3)
|
||||
real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3))
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pxx,pxy,pxz,pyy,pyz,pzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: sxx,sxy,sxz,syx,syy,syz,szx,szy,szz
|
||||
!local variable
|
||||
real*8, dimension(ex(1),ex(2),ex(3))::XX,YY,ZZ
|
||||
integer::i,j,k
|
||||
|
||||
do j = 1,ex(2)
|
||||
do k = 1,ex(3)
|
||||
XX(:,j,k) = X
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = 1,ex(1)
|
||||
do k = 1,ex(3)
|
||||
YY(i,:,k) = Y
|
||||
enddo
|
||||
enddo
|
||||
|
||||
do i = 1,ex(1)
|
||||
do j = 1,ex(2)
|
||||
ZZ(i,j,:) = Z
|
||||
enddo
|
||||
enddo
|
||||
|
||||
sxx = YY*pxy - ZZ*pxz
|
||||
sxy = YY*pyy - ZZ*pyz
|
||||
sxz = YY*pyz - ZZ*pzz
|
||||
syx = ZZ*pxy - YY*pxz
|
||||
syy = ZZ*pyy - YY*pyz
|
||||
syz = ZZ*pyz - YY*pzz
|
||||
szx = XX*pxy - YY*pxx
|
||||
szy = XX*pyy - YY*pxy
|
||||
szz = XX*pyz - YY*pxz
|
||||
|
||||
return
|
||||
|
||||
end subroutine admangularmomentum_bssn
|
||||
|
||||
! for shell
|
||||
subroutine admmass_bssn_ss(ex,crho,sigma,R, X, Y, Z, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz, &
|
||||
drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, &
|
||||
dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, &
|
||||
dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, &
|
||||
chi , trK, &
|
||||
dxx , gxy , gxz , dyy , gyz , dzz , &
|
||||
Axx , Axy , Axz , Ayy , Ayz , Azz , &
|
||||
Gamx , Gamy , Gamz , &
|
||||
massx,massy,massz, symmetry,sst)
|
||||
|
||||
implicit none
|
||||
!~~~~~~= Input parameters:
|
||||
|
||||
integer,intent(in) :: ex(1:3),symmetry,sst
|
||||
double precision,intent(in),dimension(ex(1))::crho
|
||||
double precision,intent(in),dimension(ex(2))::sigma
|
||||
double precision,intent(in),dimension(ex(3))::R
|
||||
real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3))
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz
|
||||
double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: massx,massy,massz
|
||||
! local variables
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz
|
||||
! inverse metric
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz
|
||||
! partial derivative of chi, chi_i
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: f
|
||||
real*8 :: PI, F1o2pi
|
||||
real*8, parameter :: ONE = 1.d0, F1o8 = 1.d0/8.d0
|
||||
real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0
|
||||
real*8 :: dX, dY, dZ
|
||||
|
||||
dX = X(2) - X(1)
|
||||
dY = Y(2) - Y(1)
|
||||
dZ = Z(2) - Z(1)
|
||||
|
||||
PI = dacos( - ONE )
|
||||
F1o2pi = ONE / ( 2.d0 * PI )
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, &
|
||||
drhodx, drhody, drhodz, &
|
||||
dsigmadx,dsigmady,dsigmadz, &
|
||||
dRdx,dRdy,dRdz)
|
||||
|
||||
f=1/4.d0/(chi+ONE)**1.25d0
|
||||
! mass_i = (Gami/8 + gupij*phi_j/(4*chi^1.25))/(2*Pi)
|
||||
massx = (F1o8*Gamx + f*(gupxx*chix+gupxy*chiy+gupxz*chiz))*F1o2pi
|
||||
massy = (F1o8*Gamy + f*(gupxy*chix+gupyy*chiy+gupyz*chiz))*F1o2pi
|
||||
massz = (F1o8*Gamz + f*(gupxz*chix+gupyz*chiy+gupzz*chiz))*F1o2pi
|
||||
|
||||
return
|
||||
|
||||
end subroutine admmass_bssn_ss
|
||||
60
AMSS_NCKU_source/BSSN/fadmquantites_bssn.h
Normal file
60
AMSS_NCKU_source/BSSN/fadmquantites_bssn.h
Normal file
@@ -0,0 +1,60 @@
|
||||
|
||||
#ifndef FADMQUANTITES_H
|
||||
#define FADMQUANTITES_H
|
||||
|
||||
#ifdef fortran1
|
||||
#define f_admmass_bssn admmass_bssn
|
||||
#define f_admmass_bssn_ss admmass_bssn_ss
|
||||
#define f_admmomentum_bssn admmomentum_bssn
|
||||
#endif
|
||||
#ifdef fortran2
|
||||
#define f_admmass_bssn ADMMASS_BSSN
|
||||
#define f_admmass_bssn_ss ADMMASS_BSSN_SS
|
||||
#define f_admmomentum_bssn ADMMOMENTUM_BSSN
|
||||
#endif
|
||||
#ifdef fortran3
|
||||
#define f_admmass_bssn admmass_bssn_
|
||||
#define f_admmass_bssn_ss admmass_bssn_ss_
|
||||
#define f_admmomentum_bssn admmomentum_bssn_
|
||||
#endif
|
||||
|
||||
extern "C"
|
||||
{
|
||||
void f_admmass_bssn(int *, double *, double *, double *,
|
||||
double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
void f_admmass_bssn_ss(int *, double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
int &, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
void f_admmomentum_bssn(int *, double *, double *, double *,
|
||||
double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *,
|
||||
double *, double *, double *, double *, double *, double *);
|
||||
}
|
||||
#endif /* FADMQUANTITES_H */
|
||||
91
AMSS_NCKU_source/BSSN/fourdcurvature.f90
Normal file
91
AMSS_NCKU_source/BSSN/fourdcurvature.f90
Normal file
@@ -0,0 +1,91 @@
|
||||
|
||||
|
||||
#include "macrodef.fh"
|
||||
|
||||
!-----------------------------------------------------------------------------
|
||||
!
|
||||
! compute 4 dimensional Ricci scalar
|
||||
! this routine is valid for both box and shell
|
||||
!
|
||||
!-----------------------------------------------------------------------------
|
||||
|
||||
subroutine get4ricciscalar(ex, X, Y, Z, &
|
||||
chi, trK, rho, &
|
||||
dxx,gxy,gxz,dyy,gyz,dzz, &
|
||||
Axx,Axy,Axz,Ayy,Ayz,Azz, &
|
||||
Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,&
|
||||
Sxx,Sxy,Sxz,Syy,Syz,Szz,&
|
||||
RR)
|
||||
|
||||
implicit none
|
||||
|
||||
!~~~~~~> Input parameters:
|
||||
|
||||
integer,intent(in ):: ex(1:3)
|
||||
real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3))
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,rho
|
||||
! physical Ricci tensor
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz
|
||||
! matter
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: Sxx,Sxy,Sxz,Syy,Syz,Szz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: RR
|
||||
|
||||
!~~~~~~> Other variables:
|
||||
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,chipn1
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz
|
||||
real*8, parameter :: ONE = 1.d0, TWO = 2.d0, THR = 3.d0, F8 = 8.d0, F2o3 = 2.d0/3.d0
|
||||
real*8 :: PI
|
||||
|
||||
PI = dacos(-ONE)
|
||||
|
||||
gxx = dxx + ONE
|
||||
gyy = dyy + ONE
|
||||
gzz = dzz + ONE
|
||||
chipn1= chi + ONE
|
||||
|
||||
! invert tilted metric
|
||||
gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
|
||||
gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
|
||||
gupxx = ( gyy * gzz - gyz * gyz ) / gupzz
|
||||
gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz
|
||||
gupxz = ( gxy * gyz - gyy * gxz ) / gupzz
|
||||
gupyy = ( gxx * gzz - gxz * gxz ) / gupzz
|
||||
gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz
|
||||
gupzz = ( gxx * gyy - gxy * gxy ) / gupzz
|
||||
|
||||
RR =(gupxx * ( &
|
||||
gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + &
|
||||
TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + &
|
||||
gupyy * ( &
|
||||
gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + &
|
||||
TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + &
|
||||
gupzz * ( &
|
||||
gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + &
|
||||
TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + &
|
||||
TWO * ( &
|
||||
gupxy * ( &
|
||||
gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + &
|
||||
gupxy * (Axx * Ayy + Axy * Axy) + &
|
||||
gupxz * (Axx * Ayz + Axz * Axy) + &
|
||||
gupyz * (Axy * Ayz + Axz * Ayy) ) + &
|
||||
gupxz * ( &
|
||||
gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + &
|
||||
gupxy * (Axx * Ayz + Axy * Axz) + &
|
||||
gupxz * (Axx * Azz + Axz * Axz) + &
|
||||
gupyz * (Axy * Azz + Axz * Ayz) ) + &
|
||||
gupyz * ( &
|
||||
gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + &
|
||||
gupxy * (Axy * Ayz + Ayy * Axz) + &
|
||||
gupxz * (Axy * Azz + Ayz * Axz) + &
|
||||
gupyz * (Ayy * Azz + Ayz * Ayz) ) )) - F2o3*trK*trK &
|
||||
-(gupxx*Rxx+gupyy*Ryy+gupzz*Rzz+TWO*(gupxy*Rxy+gupxz*Rxz+gupyz*Ryz))*chipn1 &
|
||||
-F8*PI*(THR*rho- &
|
||||
(gupxx*Sxx+gupyy*Syy+gupzz*Szz+TWO*(gupxy*Sxy+gupxz*Sxz+gupyz*Syz))*chipn1)
|
||||
|
||||
return
|
||||
|
||||
end subroutine get4ricciscalar
|
||||
255
AMSS_NCKU_source/BSSN/lopsided_c.C
Normal file
255
AMSS_NCKU_source/BSSN/lopsided_c.C
Normal file
@@ -0,0 +1,255 @@
|
||||
#include "tool.h"
|
||||
/*
|
||||
* 你需要提供 symmetry_bd 的 C 版本（或 Fortran 绑到 C 的接口）。
|
||||
* Fortran: call symmetry_bd(3,ex,f,fh,SoA)
|
||||
*
|
||||
* 约定：
|
||||
* nghost = 3
|
||||
* ex[3] = {ex1,ex2,ex3}
|
||||
* f = 原始网格 (ex1*ex2*ex3)
|
||||
* fh = 扩展网格 ((ex1+3)*(ex2+3)*(ex3+3))，对应 Fortran 的 (-2:ex1, ...)
|
||||
* SoA[3] = 输入参数
|
||||
*/
|
||||
void lopsided(const int ex[3],
|
||||
const double *X, const double *Y, const double *Z,
|
||||
const double *f, double *f_rhs,
|
||||
const double *Sfx, const double *Sfy, const double *Sfz,
|
||||
int Symmetry, const double SoA[3])
|
||||
{
|
||||
const double ZEO = 0.0, ONE = 1.0, F3 = 3.0;
|
||||
const double TWO = 2.0, F6 = 6.0, F18 = 18.0;
|
||||
const double F12 = 12.0, F10 = 10.0, EIT = 8.0;
|
||||
|
||||
const int NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2;
|
||||
(void)OCTANT; // 这里和 Fortran 一样只是定义了不用也没关系
|
||||
|
||||
const int ex1 = ex[0], ex2 = ex[1], ex3 = ex[2];
|
||||
|
||||
// 对应 Fortran: dX = X(2)-X(1) （Fortran 1-based）
|
||||
// C: X[1]-X[0]
|
||||
const double dX = X[1] - X[0];
|
||||
const double dY = Y[1] - Y[0];
|
||||
const double dZ = Z[1] - Z[0];
|
||||
|
||||
const double d12dx = ONE / F12 / dX;
|
||||
const double d12dy = ONE / F12 / dY;
|
||||
const double d12dz = ONE / F12 / dZ;
|
||||
|
||||
// Fortran 里算了 d2dx/d2dy/d2dz 但本 subroutine 里没用到（保持一致也算出来）
|
||||
const double d2dx = ONE / TWO / dX;
|
||||
const double d2dy = ONE / TWO / dY;
|
||||
const double d2dz = ONE / TWO / dZ;
|
||||
(void)d2dx; (void)d2dy; (void)d2dz;
|
||||
|
||||
// Fortran:
|
||||
// imax = ex(1); jmax = ex(2); kmax = ex(3)
|
||||
const int imaxF = ex1;
|
||||
const int jmaxF = ex2;
|
||||
const int kmaxF = ex3;
|
||||
|
||||
// Fortran:
|
||||
// imin=jmin=kmin=1; 若满足对称条件则设为 -2
|
||||
int iminF = 1, jminF = 1, kminF = 1;
|
||||
if (Symmetry > NO_SYMM && fabs(Z[0]) < dZ) kminF = -2;
|
||||
if (Symmetry > EQ_SYMM && fabs(X[0]) < dX) iminF = -2;
|
||||
if (Symmetry > EQ_SYMM && fabs(Y[0]) < dY) jminF = -2;
|
||||
|
||||
// 分配 fh：大小 (ex1+3)*(ex2+3)*(ex3+3)
|
||||
const size_t nx = (size_t)ex1 + 3;
|
||||
const size_t ny = (size_t)ex2 + 3;
|
||||
const size_t nz = (size_t)ex3 + 3;
|
||||
const size_t fh_size = nx * ny * nz;
|
||||
|
||||
double *fh = (double*)malloc(fh_size * sizeof(double));
|
||||
if (!fh) return; // 内存不足：直接返回（你也可以改成 abort/报错）
|
||||
|
||||
// Fortran: call symmetry_bd(3,ex,f,fh,SoA)
|
||||
symmetry_bd(3, ex, f, fh, SoA);
|
||||
|
||||
/*
|
||||
* Fortran 主循环：
|
||||
* do k=1,ex(3)-1
|
||||
* do j=1,ex(2)-1
|
||||
* do i=1,ex(1)-1
|
||||
*
|
||||
* 转成 C 0-based：
|
||||
* k0 = 0..ex3-2, j0 = 0..ex2-2, i0 = 0..ex1-2
|
||||
*
|
||||
* 并且 Fortran 里的 i/j/k 在 fh 访问时，仍然是 Fortran 索引值：
|
||||
* iF=i0+1, jF=j0+1, kF=k0+1
|
||||
*/
|
||||
for (int k0 = 0; k0 <= ex3 - 2; ++k0) {
|
||||
const int kF = k0 + 1;
|
||||
for (int j0 = 0; j0 <= ex2 - 2; ++j0) {
|
||||
const int jF = j0 + 1;
|
||||
for (int i0 = 0; i0 <= ex1 - 2; ++i0) {
|
||||
const int iF = i0 + 1;
|
||||
|
||||
const size_t p = idx_ex(i0, j0, k0, ex);
|
||||
|
||||
// ---------------- x direction ----------------
|
||||
const double sfx = Sfx[p];
|
||||
if (sfx > ZEO) {
|
||||
// Fortran: if(i+3 <= imax)
|
||||
// iF+3 <= ex1 <=> i0+4 <= ex1 <=> i0 <= ex1-4
|
||||
if (i0 <= ex1 - 4) {
|
||||
f_rhs[p] += sfx * d12dx *
|
||||
(-F3 * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF , jF, kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF + 2, jF, kF, ex)]
|
||||
+ fh[idx_fh_F(iF + 3, jF, kF, ex)]);
|
||||
}
|
||||
// elseif(i+2 <= imax) <=> i0 <= ex1-3
|
||||
else if (i0 <= ex1 - 3) {
|
||||
f_rhs[p] += sfx * d12dx *
|
||||
( fh[idx_fh_F(iF - 2, jF, kF, ex)]
|
||||
-EIT * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
+EIT * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
- fh[idx_fh_F(iF + 2, jF, kF, ex)]);
|
||||
}
|
||||
// elseif(i+1 <= imax) <=> i0 <= ex1-2（循环里总成立）
|
||||
else if (i0 <= ex1 - 2) {
|
||||
f_rhs[p] -= sfx * d12dx *
|
||||
(-F3 * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF , jF, kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF - 2, jF, kF, ex)]
|
||||
+ fh[idx_fh_F(iF - 3, jF, kF, ex)]);
|
||||
}
|
||||
} else if (sfx < ZEO) {
|
||||
// Fortran: if(i-3 >= imin)
|
||||
// (iF-3) >= iminF <=> (i0-2) >= iminF
|
||||
if ((i0 - 2) >= iminF) {
|
||||
f_rhs[p] -= sfx * d12dx *
|
||||
(-F3 * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF , jF, kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF - 2, jF, kF, ex)]
|
||||
+ fh[idx_fh_F(iF - 3, jF, kF, ex)]);
|
||||
}
|
||||
// elseif(i-2 >= imin) <=> (i0-1) >= iminF
|
||||
else if ((i0 - 1) >= iminF) {
|
||||
f_rhs[p] += sfx * d12dx *
|
||||
( fh[idx_fh_F(iF - 2, jF, kF, ex)]
|
||||
-EIT * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
+EIT * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
- fh[idx_fh_F(iF + 2, jF, kF, ex)]);
|
||||
}
|
||||
// elseif(i-1 >= imin) <=> i0 >= iminF
|
||||
else if (i0 >= iminF) {
|
||||
f_rhs[p] += sfx * d12dx *
|
||||
(-F3 * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF , jF, kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF + 2, jF, kF, ex)]
|
||||
+ fh[idx_fh_F(iF + 3, jF, kF, ex)]);
|
||||
}
|
||||
}
|
||||
|
||||
// ---------------- y direction ----------------
|
||||
const double sfy = Sfy[p];
|
||||
if (sfy > ZEO) {
|
||||
// jF+3 <= ex2 <=> j0+4 <= ex2 <=> j0 <= ex2-4
|
||||
if (j0 <= ex2 - 4) {
|
||||
f_rhs[p] += sfy * d12dy *
|
||||
(-F3 * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF , kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF + 2, kF, ex)]
|
||||
+ fh[idx_fh_F(iF, jF + 3, kF, ex)]);
|
||||
} else if (j0 <= ex2 - 3) {
|
||||
f_rhs[p] += sfy * d12dy *
|
||||
( fh[idx_fh_F(iF, jF - 2, kF, ex)]
|
||||
-EIT * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
+EIT * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
- fh[idx_fh_F(iF, jF + 2, kF, ex)]);
|
||||
} else if (j0 <= ex2 - 2) {
|
||||
f_rhs[p] -= sfy * d12dy *
|
||||
(-F3 * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF , kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF - 2, kF, ex)]
|
||||
+ fh[idx_fh_F(iF, jF - 3, kF, ex)]);
|
||||
}
|
||||
} else if (sfy < ZEO) {
|
||||
if ((j0 - 2) >= jminF) {
|
||||
f_rhs[p] -= sfy * d12dy *
|
||||
(-F3 * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF , kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF - 2, kF, ex)]
|
||||
+ fh[idx_fh_F(iF, jF - 3, kF, ex)]);
|
||||
} else if ((j0 - 1) >= jminF) {
|
||||
f_rhs[p] += sfy * d12dy *
|
||||
( fh[idx_fh_F(iF, jF - 2, kF, ex)]
|
||||
-EIT * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
+EIT * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
- fh[idx_fh_F(iF, jF + 2, kF, ex)]);
|
||||
} else if (j0 >= jminF) {
|
||||
f_rhs[p] += sfy * d12dy *
|
||||
(-F3 * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF , kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF + 2, kF, ex)]
|
||||
+ fh[idx_fh_F(iF, jF + 3, kF, ex)]);
|
||||
}
|
||||
}
|
||||
|
||||
// ---------------- z direction ----------------
|
||||
const double sfz = Sfz[p];
|
||||
if (sfz > ZEO) {
|
||||
if (k0 <= ex3 - 4) {
|
||||
f_rhs[p] += sfz * d12dz *
|
||||
(-F3 * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF, kF , ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF, kF + 2, ex)]
|
||||
+ fh[idx_fh_F(iF, jF, kF + 3, ex)]);
|
||||
} else if (k0 <= ex3 - 3) {
|
||||
f_rhs[p] += sfz * d12dz *
|
||||
( fh[idx_fh_F(iF, jF, kF - 2, ex)]
|
||||
-EIT * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
+EIT * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
- fh[idx_fh_F(iF, jF, kF + 2, ex)]);
|
||||
} else if (k0 <= ex3 - 2) {
|
||||
f_rhs[p] -= sfz * d12dz *
|
||||
(-F3 * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF, kF , ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF, kF - 2, ex)]
|
||||
+ fh[idx_fh_F(iF, jF, kF - 3, ex)]);
|
||||
}
|
||||
} else if (sfz < ZEO) {
|
||||
if ((k0 - 2) >= kminF) {
|
||||
f_rhs[p] -= sfz * d12dz *
|
||||
(-F3 * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF, kF , ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF, kF - 2, ex)]
|
||||
+ fh[idx_fh_F(iF, jF, kF - 3, ex)]);
|
||||
} else if ((k0 - 1) >= kminF) {
|
||||
f_rhs[p] += sfz * d12dz *
|
||||
( fh[idx_fh_F(iF, jF, kF - 2, ex)]
|
||||
-EIT * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
+EIT * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
- fh[idx_fh_F(iF, jF, kF + 2, ex)]);
|
||||
} else if (k0 >= kminF) {
|
||||
f_rhs[p] += sfz * d12dz *
|
||||
(-F3 * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF, kF , ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF, kF + 2, ex)]
|
||||
+ fh[idx_fh_F(iF, jF, kF + 3, ex)]);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
free(fh);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
248
AMSS_NCKU_source/BSSN/lopsided_kodis_c.C
Normal file
248
AMSS_NCKU_source/BSSN/lopsided_kodis_c.C
Normal file
@@ -0,0 +1,248 @@
|
||||
#include "tool.h"
|
||||
|
||||
/*
|
||||
* Combined advection (lopsided) + KO dissipation (kodis).
|
||||
* Uses one shared symmetry_bd buffer per call.
|
||||
*/
|
||||
void lopsided_kodis(const int ex[3],
|
||||
const double *X, const double *Y, const double *Z,
|
||||
const double *f, double *f_rhs,
|
||||
const double *Sfx, const double *Sfy, const double *Sfz,
|
||||
int Symmetry, const double SoA[3], double eps)
|
||||
{
|
||||
const double ZEO = 0.0, ONE = 1.0, F3 = 3.0;
|
||||
const double F6 = 6.0, F18 = 18.0;
|
||||
const double F12 = 12.0, F10 = 10.0, EIT = 8.0;
|
||||
const double SIX = 6.0, FIT = 15.0, TWT = 20.0;
|
||||
const double cof = 64.0; // 2^6
|
||||
|
||||
const int NO_SYMM = 0, EQ_SYMM = 1;
|
||||
|
||||
const int ex1 = ex[0], ex2 = ex[1], ex3 = ex[2];
|
||||
|
||||
const double dX = X[1] - X[0];
|
||||
const double dY = Y[1] - Y[0];
|
||||
const double dZ = Z[1] - Z[0];
|
||||
|
||||
const double d12dx = ONE / F12 / dX;
|
||||
const double d12dy = ONE / F12 / dY;
|
||||
const double d12dz = ONE / F12 / dZ;
|
||||
|
||||
const int imaxF = ex1;
|
||||
const int jmaxF = ex2;
|
||||
const int kmaxF = ex3;
|
||||
|
||||
int iminF = 1, jminF = 1, kminF = 1;
|
||||
if (Symmetry > NO_SYMM && fabs(Z[0]) < dZ) kminF = -2;
|
||||
if (Symmetry > EQ_SYMM && fabs(X[0]) < dX) iminF = -2;
|
||||
if (Symmetry > EQ_SYMM && fabs(Y[0]) < dY) jminF = -2;
|
||||
|
||||
// fh for Fortran-style domain (-2:ex1,-2:ex2,-2:ex3)
|
||||
const size_t nx = (size_t)ex1 + 3;
|
||||
const size_t ny = (size_t)ex2 + 3;
|
||||
const size_t nz = (size_t)ex3 + 3;
|
||||
const size_t fh_size = nx * ny * nz;
|
||||
|
||||
double *fh = (double*)malloc(fh_size * sizeof(double));
|
||||
if (!fh) return;
|
||||
|
||||
symmetry_bd(3, ex, f, fh, SoA);
|
||||
|
||||
// Advection (same stencil logic as lopsided_c.C)
|
||||
for (int k0 = 0; k0 <= ex3 - 2; ++k0) {
|
||||
const int kF = k0 + 1;
|
||||
for (int j0 = 0; j0 <= ex2 - 2; ++j0) {
|
||||
const int jF = j0 + 1;
|
||||
for (int i0 = 0; i0 <= ex1 - 2; ++i0) {
|
||||
const int iF = i0 + 1;
|
||||
const size_t p = idx_ex(i0, j0, k0, ex);
|
||||
|
||||
const double sfx = Sfx[p];
|
||||
if (sfx > ZEO) {
|
||||
if (i0 <= ex1 - 4) {
|
||||
f_rhs[p] += sfx * d12dx *
|
||||
(-F3 * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF , jF, kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF + 2, jF, kF, ex)]
|
||||
+ fh[idx_fh_F(iF + 3, jF, kF, ex)]);
|
||||
} else if (i0 <= ex1 - 3) {
|
||||
f_rhs[p] += sfx * d12dx *
|
||||
( fh[idx_fh_F(iF - 2, jF, kF, ex)]
|
||||
-EIT * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
+EIT * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
- fh[idx_fh_F(iF + 2, jF, kF, ex)]);
|
||||
} else if (i0 <= ex1 - 2) {
|
||||
f_rhs[p] -= sfx * d12dx *
|
||||
(-F3 * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF , jF, kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF - 2, jF, kF, ex)]
|
||||
+ fh[idx_fh_F(iF - 3, jF, kF, ex)]);
|
||||
}
|
||||
} else if (sfx < ZEO) {
|
||||
if ((i0 - 2) >= iminF) {
|
||||
f_rhs[p] -= sfx * d12dx *
|
||||
(-F3 * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF , jF, kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF - 2, jF, kF, ex)]
|
||||
+ fh[idx_fh_F(iF - 3, jF, kF, ex)]);
|
||||
} else if ((i0 - 1) >= iminF) {
|
||||
f_rhs[p] += sfx * d12dx *
|
||||
( fh[idx_fh_F(iF - 2, jF, kF, ex)]
|
||||
-EIT * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
+EIT * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
- fh[idx_fh_F(iF + 2, jF, kF, ex)]);
|
||||
} else if (i0 >= iminF) {
|
||||
f_rhs[p] += sfx * d12dx *
|
||||
(-F3 * fh[idx_fh_F(iF - 1, jF, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF , jF, kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF + 1, jF, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF + 2, jF, kF, ex)]
|
||||
+ fh[idx_fh_F(iF + 3, jF, kF, ex)]);
|
||||
}
|
||||
}
|
||||
|
||||
const double sfy = Sfy[p];
|
||||
if (sfy > ZEO) {
|
||||
if (j0 <= ex2 - 4) {
|
||||
f_rhs[p] += sfy * d12dy *
|
||||
(-F3 * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF , kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF + 2, kF, ex)]
|
||||
+ fh[idx_fh_F(iF, jF + 3, kF, ex)]);
|
||||
} else if (j0 <= ex2 - 3) {
|
||||
f_rhs[p] += sfy * d12dy *
|
||||
( fh[idx_fh_F(iF, jF - 2, kF, ex)]
|
||||
-EIT * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
+EIT * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
- fh[idx_fh_F(iF, jF + 2, kF, ex)]);
|
||||
} else if (j0 <= ex2 - 2) {
|
||||
f_rhs[p] -= sfy * d12dy *
|
||||
(-F3 * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF , kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF - 2, kF, ex)]
|
||||
+ fh[idx_fh_F(iF, jF - 3, kF, ex)]);
|
||||
}
|
||||
} else if (sfy < ZEO) {
|
||||
if ((j0 - 2) >= jminF) {
|
||||
f_rhs[p] -= sfy * d12dy *
|
||||
(-F3 * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF , kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF - 2, kF, ex)]
|
||||
+ fh[idx_fh_F(iF, jF - 3, kF, ex)]);
|
||||
} else if ((j0 - 1) >= jminF) {
|
||||
f_rhs[p] += sfy * d12dy *
|
||||
( fh[idx_fh_F(iF, jF - 2, kF, ex)]
|
||||
-EIT * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
+EIT * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
- fh[idx_fh_F(iF, jF + 2, kF, ex)]);
|
||||
} else if (j0 >= jminF) {
|
||||
f_rhs[p] += sfy * d12dy *
|
||||
(-F3 * fh[idx_fh_F(iF, jF - 1, kF, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF , kF, ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF + 1, kF, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF + 2, kF, ex)]
|
||||
+ fh[idx_fh_F(iF, jF + 3, kF, ex)]);
|
||||
}
|
||||
}
|
||||
|
||||
const double sfz = Sfz[p];
|
||||
if (sfz > ZEO) {
|
||||
if (k0 <= ex3 - 4) {
|
||||
f_rhs[p] += sfz * d12dz *
|
||||
(-F3 * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF, kF , ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF, kF + 2, ex)]
|
||||
+ fh[idx_fh_F(iF, jF, kF + 3, ex)]);
|
||||
} else if (k0 <= ex3 - 3) {
|
||||
f_rhs[p] += sfz * d12dz *
|
||||
( fh[idx_fh_F(iF, jF, kF - 2, ex)]
|
||||
-EIT * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
+EIT * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
- fh[idx_fh_F(iF, jF, kF + 2, ex)]);
|
||||
} else if (k0 <= ex3 - 2) {
|
||||
f_rhs[p] -= sfz * d12dz *
|
||||
(-F3 * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF, kF , ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF, kF - 2, ex)]
|
||||
+ fh[idx_fh_F(iF, jF, kF - 3, ex)]);
|
||||
}
|
||||
} else if (sfz < ZEO) {
|
||||
if ((k0 - 2) >= kminF) {
|
||||
f_rhs[p] -= sfz * d12dz *
|
||||
(-F3 * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF, kF , ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF, kF - 2, ex)]
|
||||
+ fh[idx_fh_F(iF, jF, kF - 3, ex)]);
|
||||
} else if ((k0 - 1) >= kminF) {
|
||||
f_rhs[p] += sfz * d12dz *
|
||||
( fh[idx_fh_F(iF, jF, kF - 2, ex)]
|
||||
-EIT * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
+EIT * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
- fh[idx_fh_F(iF, jF, kF + 2, ex)]);
|
||||
} else if (k0 >= kminF) {
|
||||
f_rhs[p] += sfz * d12dz *
|
||||
(-F3 * fh[idx_fh_F(iF, jF, kF - 1, ex)]
|
||||
-F10 * fh[idx_fh_F(iF, jF, kF , ex)]
|
||||
+F18 * fh[idx_fh_F(iF, jF, kF + 1, ex)]
|
||||
-F6 * fh[idx_fh_F(iF, jF, kF + 2, ex)]
|
||||
+ fh[idx_fh_F(iF, jF, kF + 3, ex)]);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// KO dissipation (same domain restriction as kodiss_c.C)
|
||||
if (eps > ZEO) {
|
||||
const int i0_lo = (iminF + 2 > 0) ? iminF + 2 : 0;
|
||||
const int j0_lo = (jminF + 2 > 0) ? jminF + 2 : 0;
|
||||
const int k0_lo = (kminF + 2 > 0) ? kminF + 2 : 0;
|
||||
const int i0_hi = imaxF - 4; // inclusive
|
||||
const int j0_hi = jmaxF - 4;
|
||||
const int k0_hi = kmaxF - 4;
|
||||
|
||||
if (!(i0_lo > i0_hi || j0_lo > j0_hi || k0_lo > k0_hi)) {
|
||||
for (int k0 = k0_lo; k0 <= k0_hi; ++k0) {
|
||||
const int kF = k0 + 1;
|
||||
for (int j0 = j0_lo; j0 <= j0_hi; ++j0) {
|
||||
const int jF = j0 + 1;
|
||||
for (int i0 = i0_lo; i0 <= i0_hi; ++i0) {
|
||||
const int iF = i0 + 1;
|
||||
const size_t p = idx_ex(i0, j0, k0, ex);
|
||||
|
||||
const double Dx_term =
|
||||
((fh[idx_fh_F(iF - 3, jF, kF, ex)] + fh[idx_fh_F(iF + 3, jF, kF, ex)]) -
|
||||
SIX * (fh[idx_fh_F(iF - 2, jF, kF, ex)] + fh[idx_fh_F(iF + 2, jF, kF, ex)]) +
|
||||
FIT * (fh[idx_fh_F(iF - 1, jF, kF, ex)] + fh[idx_fh_F(iF + 1, jF, kF, ex)]) -
|
||||
TWT * fh[idx_fh_F(iF, jF, kF, ex)]) / dX;
|
||||
|
||||
const double Dy_term =
|
||||
((fh[idx_fh_F(iF, jF - 3, kF, ex)] + fh[idx_fh_F(iF, jF + 3, kF, ex)]) -
|
||||
SIX * (fh[idx_fh_F(iF, jF - 2, kF, ex)] + fh[idx_fh_F(iF, jF + 2, kF, ex)]) +
|
||||
FIT * (fh[idx_fh_F(iF, jF - 1, kF, ex)] + fh[idx_fh_F(iF, jF + 1, kF, ex)]) -
|
||||
TWT * fh[idx_fh_F(iF, jF, kF, ex)]) / dY;
|
||||
|
||||
const double Dz_term =
|
||||
((fh[idx_fh_F(iF, jF, kF - 3, ex)] + fh[idx_fh_F(iF, jF, kF + 3, ex)]) -
|
||||
SIX * (fh[idx_fh_F(iF, jF, kF - 2, ex)] + fh[idx_fh_F(iF, jF, kF + 2, ex)]) +
|
||||
FIT * (fh[idx_fh_F(iF, jF, kF - 1, ex)] + fh[idx_fh_F(iF, jF, kF + 1, ex)]) -
|
||||
TWT * fh[idx_fh_F(iF, jF, kF, ex)]) / dZ;
|
||||
|
||||
f_rhs[p] += (eps / cof) * (Dx_term + Dy_term + Dz_term);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
free(fh);
|
||||
}
|
||||
1097
AMSS_NCKU_source/BSSN/lopsidediff.f90
Normal file
1097
AMSS_NCKU_source/BSSN/lopsidediff.f90
Normal file
File diff suppressed because it is too large
Load Diff
3554
AMSS_NCKU_source/BSSN/prolongrestrict.f90
Normal file
3554
AMSS_NCKU_source/BSSN/prolongrestrict.f90
Normal file
File diff suppressed because it is too large
Load Diff
55
AMSS_NCKU_source/BSSN/prolongrestrict.h
Normal file
55
AMSS_NCKU_source/BSSN/prolongrestrict.h
Normal file
@@ -0,0 +1,55 @@
|
||||
|
||||
#ifndef PROLONGRESTRICT_H
|
||||
#define PROLONGRESTRICT_H
|
||||
|
||||
#ifdef fortran1
|
||||
#define f_prolong3 prolong3
|
||||
#define f_prolongmix3 prolongmix3
|
||||
#define f_prolongcopy3 prolongcopy3
|
||||
#define f_restrict3 restrict3
|
||||
#endif
|
||||
|
||||
#ifdef fortran2
|
||||
#define f_prolong3 PROLONG3
|
||||
#define f_prolongmix3 PROLONGMIX3
|
||||
#define f_prolongcopy3 PROLONGCOPY3
|
||||
#define f_restrict3 RESTRICT3
|
||||
#endif
|
||||
|
||||
#ifdef fortran3
|
||||
#define f_prolong3 prolong3_
|
||||
#define f_prolongmix3 prolongmix3_
|
||||
#define f_prolongcopy3 prolongcopy3_
|
||||
#define f_restrict3 restrict3_
|
||||
#endif
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_prolong3(int &, double *, double *, int *, double *,
|
||||
double *, double *, int *, double *,
|
||||
double *, double *, double *, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
void f_restrict3(int &, double *, double *, int *, double *,
|
||||
double *, double *, int *, double *,
|
||||
double *, double *, double *, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_prolongmix3(int &, double *, double *, int *, double *,
|
||||
double *, double *, int *, double *,
|
||||
double *, double *, double *, int &,
|
||||
double *, double *);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
int f_prolongcopy3(int &, double *, double *, int *, double *,
|
||||
double *, double *, int *, double *,
|
||||
double *, double *, double *, int &);
|
||||
}
|
||||
|
||||
#endif /* PROLONGRESTRICT_H */
|
||||
3745
AMSS_NCKU_source/BSSN/prolongrestrict_cell.f90
Normal file
3745
AMSS_NCKU_source/BSSN/prolongrestrict_cell.f90
Normal file
File diff suppressed because it is too large
Load Diff
1925
AMSS_NCKU_source/BSSN/prolongrestrict_vertex.f90
Normal file
1925
AMSS_NCKU_source/BSSN/prolongrestrict_vertex.f90
Normal file
File diff suppressed because it is too large
Load Diff
647
AMSS_NCKU_source/BSSN/sommerfeld_rout.f90
Normal file
647
AMSS_NCKU_source/BSSN/sommerfeld_rout.f90
Normal file
@@ -0,0 +1,647 @@
|
||||
|
||||
|
||||
#include "macrodef.fh"
|
||||
|
||||
! Update outer boundaries with Sommerfeld boundary condition
|
||||
!
|
||||
!-----------------------------------------------------------------------------
|
||||
!5th order interpolation
|
||||
subroutine sommerfeld_rout(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,dT,chi0,&
|
||||
Lap0,f0,f,SoA,Symmetry,precor)
|
||||
|
||||
implicit none
|
||||
|
||||
!~~~~~~> Input parameters:
|
||||
integer, intent(in):: ex(1:3),Symmetry,precor
|
||||
real*8, dimension(ex(1)) :: X
|
||||
real*8, dimension(ex(2)) :: Y
|
||||
real*8, dimension(ex(3)) :: Z
|
||||
real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,dT
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::chi0,Lap0,f0
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f
|
||||
real*8, dimension(3),intent(in) ::SoA
|
||||
!~~~~~~> Other variables:
|
||||
real*8 :: dX,dY,dZ,r,fac
|
||||
integer :: i, j, k,m
|
||||
logical :: gont,nouse
|
||||
integer,dimension(3) :: cxB,cxT
|
||||
integer :: layer(1:6,1:6),gp
|
||||
! index of layer, first one: i,j,k; second one: front back etc. boundary
|
||||
integer,parameter::ordn = 6, CORRECTSTEP=1
|
||||
real*8 :: ddy
|
||||
real*8, dimension(1:ordn) :: xa
|
||||
real*8, dimension(1:3) :: cx
|
||||
real*8, dimension(1:ordn,1:ordn,1:ordn) :: ya
|
||||
real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, SYM = 1.d0, ANT = -1.d0
|
||||
integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2
|
||||
!~~~~~~> Interface
|
||||
|
||||
interface
|
||||
|
||||
function decide3d(ex,f,fpi,cxB,cxT,SoA,ya,ORDN,Symmetry) result(gont)
|
||||
implicit none
|
||||
|
||||
integer, intent(in) :: ORDN,Symmetry
|
||||
integer,dimension(1:3) , intent(in) :: ex,cxB,cxT
|
||||
real*8, dimension(1:3) , intent(in) :: SoA
|
||||
real*8, dimension(ex(1),ex(2),ex(3)) , intent(in) :: f,fpi
|
||||
real*8, dimension(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)), intent(out):: ya
|
||||
logical::gont
|
||||
end function decide3d
|
||||
|
||||
end interface
|
||||
|
||||
dX = X(2) - X(1)
|
||||
dY = Y(2) - Y(1)
|
||||
dZ = Z(2) - Z(1)
|
||||
|
||||
layer(1:3,:) = 1
|
||||
layer(4:6,:) =-1
|
||||
|
||||
if(dabs(X(ex(1))-xmax) < dX)then
|
||||
layer(1,1) = ex(1)
|
||||
layer(2,1) = 1
|
||||
layer(3,1) = 1
|
||||
layer(4,1) = ex(1)
|
||||
layer(5,1) = ex(2)
|
||||
layer(6,1) = ex(3)
|
||||
endif
|
||||
|
||||
if(dabs(Y(ex(2))-ymax) < dY)then
|
||||
layer(1,2) = 1
|
||||
layer(2,2) = ex(2)
|
||||
layer(3,2) = 1
|
||||
layer(4,2) = ex(1)
|
||||
layer(5,2) = ex(2)
|
||||
layer(6,2) = ex(3)
|
||||
endif
|
||||
|
||||
|
||||
if(dabs(Z(ex(3))-zmax) < dZ)then
|
||||
layer(1,3) = 1
|
||||
layer(2,3) = 1
|
||||
layer(3,3) = ex(3)
|
||||
layer(4,3) = ex(1)
|
||||
layer(5,3) = ex(2)
|
||||
layer(6,3) = ex(3)
|
||||
endif
|
||||
! lower boundary but not symmetry boundary
|
||||
if(dabs(X(1)-xmin) < dX .and. (.not.(Symmetry==OCTANT.and.dabs(xmin)<dX/2)))then
|
||||
layer(1,4) = 1
|
||||
layer(2,4) = 1
|
||||
layer(3,4) = 1
|
||||
layer(4,4) = 1
|
||||
layer(5,4) = ex(2)
|
||||
layer(6,4) = ex(3)
|
||||
endif
|
||||
|
||||
if(dabs(Y(1)-ymin) < dY .and. (.not.(Symmetry==OCTANT.and.dabs(ymin)<dY/2)))then
|
||||
layer(1,5) = 1
|
||||
layer(2,5) = 1
|
||||
layer(3,5) = 1
|
||||
layer(4,5) = ex(1)
|
||||
layer(5,5) = 1
|
||||
layer(6,5) = ex(3)
|
||||
endif
|
||||
|
||||
if(dabs(Z(1)-zmin) < dZ .and. (.not.(Symmetry>NO_SYMM.and.dabs(zmin)<dZ/2)))then
|
||||
layer(1,6) = 1
|
||||
layer(2,6) = 1
|
||||
layer(3,6) = 1
|
||||
layer(4,6) = ex(1)
|
||||
layer(5,6) = ex(2)
|
||||
layer(6,6) = 1
|
||||
endif
|
||||
|
||||
! so x,y and z are same: 0,1,2,...,(ORDN-1)
|
||||
do i = 1, ordn
|
||||
xa(i) = dble( i - 1 )
|
||||
enddo
|
||||
|
||||
!~~~~~~> boundary calculations start...
|
||||
if( precor == CORRECTSTEP ) then
|
||||
|
||||
do gp = 1, 6, 1
|
||||
|
||||
gont = any( layer(:,gp) == - 1 )
|
||||
|
||||
if( .not. gont ) then
|
||||
|
||||
do k = layer(3,gp), layer(6,gp), 1
|
||||
do j = layer(2,gp), layer(5,gp), 1
|
||||
do i = layer(1,gp), layer(4,gp), 1
|
||||
|
||||
f(i,j,k) = f0(i,j,k)
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
do gp = 1, 6
|
||||
|
||||
gont = any( layer(:,gp) == - 1 )
|
||||
|
||||
if( .not. gont ) then
|
||||
|
||||
do k = layer(3,gp), layer(6,gp)
|
||||
do j = layer(2,gp), layer(5,gp)
|
||||
do i = layer(1,gp), layer(4,gp)
|
||||
! tc/sc*dT/r
|
||||
r = (Lap0(i,j,k) + ONE)*dsqrt(ONE+chi0(i,j,k))*dT/dsqrt(X(i)**2+Y(j)**2+Z(k)**2)
|
||||
fac=ONE-r
|
||||
cx(1) = r*X(i)/dX
|
||||
cx(2) = r*Y(j)/dY
|
||||
cx(3) = r*Z(k)/dZ
|
||||
if(cx(1)>ZEO)then
|
||||
cxB(1) = i-dint(cx(1))-ordn/2
|
||||
else
|
||||
cxB(1) = i-dint(cx(1))-ordn/2+1
|
||||
endif
|
||||
if(cx(2)>ZEO)then
|
||||
cxB(2) = j-dint(cx(2))-ordn/2
|
||||
else
|
||||
cxB(2) = j-dint(cx(2))-ordn/2+1
|
||||
endif
|
||||
if(cx(3)>ZEO)then
|
||||
cxB(3) = k-dint(cx(3))-ordn/2
|
||||
else
|
||||
cxB(3) = k-dint(cx(3))-ordn/2+1
|
||||
endif
|
||||
|
||||
where(cx>ZEO)
|
||||
cx = dint(cx)-cx+ordn/2
|
||||
elsewhere
|
||||
cx = dint(cx)-cx+ordn/2-1
|
||||
end where
|
||||
|
||||
cxT = cxB+ordn-1
|
||||
|
||||
if(Symmetry==NO_SYMM.and.cxB(3)<1)then
|
||||
cx(3)=cx(3)+(cxB(3)-1)
|
||||
cxT(3)=cxT(3)-(cxB(3)-1)
|
||||
cxB(3)=1
|
||||
endif
|
||||
if(Symmetry<OCTANT.and.cxB(2)<1)then
|
||||
cx(2)=cx(2)+(cxB(2)-1)
|
||||
cxT(2)=cxT(2)-(cxB(2)-1)
|
||||
cxB(2)=1
|
||||
endif
|
||||
if(Symmetry<OCTANT.and.cxB(1)<1)then
|
||||
cx(1)=cx(1)+(cxB(1)-1)
|
||||
cxT(1)=cxT(1)-(cxB(1)-1)
|
||||
cxB(1)=1
|
||||
endif
|
||||
do m=1,3
|
||||
if(cxT(m)>ex(m))then
|
||||
cx(m)=cx(m)+(cxT(m)-ex(m))
|
||||
cxB(m)=cxB(m)-(cxT(m)-ex(m))
|
||||
cxT(m)=ex(m)
|
||||
endif
|
||||
enddo
|
||||
|
||||
!~~~~~~> Interpolate
|
||||
nouse=decide3d(ex,f0,f0,cxB,cxT,SoA,ya,ordn,Symmetry)
|
||||
call polin3(xa,xa,xa,ya,cx(1),cx(2),cx(3),r,ddy,ordn)
|
||||
f(i,j,k)=r*fac
|
||||
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
endif
|
||||
|
||||
return
|
||||
|
||||
end subroutine sommerfeld_rout
|
||||
!sommerfeld condition following BAM code
|
||||
subroutine sommerfeld_routbam(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,f_rhs,&
|
||||
f0,velocity,SoA,Symmetry)
|
||||
|
||||
implicit none
|
||||
|
||||
!~~~~~~> Input parameters:
|
||||
integer, intent(in):: ex(1:3),Symmetry
|
||||
real*8, intent(in) :: velocity
|
||||
real*8, dimension(ex(1)) :: X
|
||||
real*8, dimension(ex(2)) :: Y
|
||||
real*8, dimension(ex(3)) :: Z
|
||||
real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::f0
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f_rhs
|
||||
real*8,dimension(3),intent(in) ::SoA
|
||||
!~~~~~~> Other variables:
|
||||
real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh
|
||||
logical :: gont
|
||||
real*8 :: dX,dY,dZ,R
|
||||
integer :: i, j, k
|
||||
real*8 :: d2dx,d2dy,d2dz
|
||||
integer :: layer(1:6,1:6),gp
|
||||
! index of layer, first one: i,j,k; second one: front back etc. boundary
|
||||
integer :: imin,jmin,kmin,imax,jmax,kmax
|
||||
real*8 :: fx,fy,fz
|
||||
real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0
|
||||
integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2
|
||||
|
||||
real*8 :: wx,wy,wz
|
||||
|
||||
dX = X(2) - X(1)
|
||||
dY = Y(2) - Y(1)
|
||||
dZ = Z(2) - Z(1)
|
||||
|
||||
d2dx = ONE/TWO/dX
|
||||
d2dy = ONE/TWO/dY
|
||||
d2dz = ONE/TWO/dZ
|
||||
|
||||
imax = ex(1)
|
||||
jmax = ex(2)
|
||||
kmax = ex(3)
|
||||
|
||||
imin = 1
|
||||
jmin = 1
|
||||
kmin = 1
|
||||
if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0
|
||||
if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0
|
||||
if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0
|
||||
|
||||
call symmetry_bd(1,ex,f0,fh,SoA)
|
||||
|
||||
layer(1:3,:) = 1
|
||||
layer(4:6,:) =-1
|
||||
|
||||
if(dabs(X(ex(1))-xmax) < dX)then
|
||||
layer(1,1) = ex(1)
|
||||
layer(2,1) = 1
|
||||
layer(3,1) = 1
|
||||
layer(4,1) = ex(1)
|
||||
layer(5,1) = ex(2)
|
||||
layer(6,1) = ex(3)
|
||||
endif
|
||||
|
||||
if(dabs(Y(ex(2))-ymax) < dY)then
|
||||
layer(1,2) = 1
|
||||
layer(2,2) = ex(2)
|
||||
layer(3,2) = 1
|
||||
layer(4,2) = ex(1)
|
||||
layer(5,2) = ex(2)
|
||||
layer(6,2) = ex(3)
|
||||
endif
|
||||
|
||||
if(dabs(Z(ex(3))-zmax) < dZ)then
|
||||
layer(1,3) = 1
|
||||
layer(2,3) = 1
|
||||
layer(3,3) = ex(3)
|
||||
layer(4,3) = ex(1)
|
||||
layer(5,3) = ex(2)
|
||||
layer(6,3) = ex(3)
|
||||
endif
|
||||
! lower boundary but not symmetry boundary
|
||||
if(dabs(X(1)-xmin) < dX .and. (.not.(Symmetry==OCTANT.and.dabs(xmin)<dX/2)))then
|
||||
layer(1,4) = 1
|
||||
layer(2,4) = 1
|
||||
layer(3,4) = 1
|
||||
layer(4,4) = 1
|
||||
layer(5,4) = ex(2)
|
||||
layer(6,4) = ex(3)
|
||||
endif
|
||||
|
||||
if(dabs(Y(1)-ymin) < dY .and. (.not.(Symmetry==OCTANT.and.dabs(ymin)<dY/2)))then
|
||||
layer(1,5) = 1
|
||||
layer(2,5) = 1
|
||||
layer(3,5) = 1
|
||||
layer(4,5) = ex(1)
|
||||
layer(5,5) = 1
|
||||
layer(6,5) = ex(3)
|
||||
endif
|
||||
|
||||
if(dabs(Z(1)-zmin) < dZ .and. (.not.(Symmetry>NO_SYMM.and.dabs(zmin)<dZ/2)))then
|
||||
layer(1,6) = 1
|
||||
layer(2,6) = 1
|
||||
layer(3,6) = 1
|
||||
layer(4,6) = ex(1)
|
||||
layer(5,6) = ex(2)
|
||||
layer(6,6) = 1
|
||||
endif
|
||||
|
||||
do gp = 1, 6
|
||||
|
||||
gont = any( layer(:,gp) == - 1 )
|
||||
|
||||
if( .not. gont ) then
|
||||
|
||||
do k = layer(3,gp), layer(6,gp)
|
||||
do j = layer(2,gp), layer(5,gp)
|
||||
do i = layer(1,gp), layer(4,gp)
|
||||
#if 0
|
||||
!! old code
|
||||
! x direction
|
||||
if(i+1 <= imax .and. i-1 >= imin)then
|
||||
fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k))
|
||||
|
||||
elseif(i==imin)then
|
||||
fx=(-fh(i,j,k)+fh(i+1,j,k))/dX
|
||||
|
||||
elseif(i==imax)then
|
||||
fx=(-fh(i-1,j,k)+fh(i,j,k))/dX
|
||||
|
||||
endif
|
||||
! y direction
|
||||
if(j+1 <= jmax .and. j-1 >= jmin)then
|
||||
fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k))
|
||||
|
||||
elseif(j==jmin)then
|
||||
fy=(-fh(i,j,k)+fh(i,j+1,k))/dY
|
||||
|
||||
elseif(j==jmax)then
|
||||
fy=(-fh(i,j-1,k)+fh(i,j,k))/dY
|
||||
|
||||
endif
|
||||
! z direction
|
||||
if(k+1 <= kmax .and. k-1 >= kmin)then
|
||||
fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1))
|
||||
|
||||
elseif(k==kmin)then
|
||||
fz=(-fh(i,j,k)+fh(i,j,k+1))/dZ
|
||||
|
||||
elseif(k==kmax)then
|
||||
fz=(-fh(i,j,k-1)+fh(i,j,k))/dZ
|
||||
|
||||
endif
|
||||
|
||||
R = dsqrt(X(i)**2+Y(j)**2+Z(k)**2)
|
||||
f_rhs(i,j,k) = -velocity*(fx*X(i) + fy*Y(j) + fz*Z(k) + f0(i,j,k))/R
|
||||
#else
|
||||
!! new code, 2012dec26, based on bam
|
||||
!! we always assume var0 = 0
|
||||
R = dsqrt(X(i)**2+Y(j)**2+Z(k)**2)
|
||||
wx = velocity*X(i)/R
|
||||
wy = velocity*Y(j)/R
|
||||
wz = velocity*Z(k)/R
|
||||
if(wx > 0)then
|
||||
if(i-2>=imin)then
|
||||
fx = d2dx*(3*fh(i,j,k)-4*fh(i-1,j,k)+fh(i-2,j,k))
|
||||
elseif(i-1>=imin)then
|
||||
fx = d2dx*(-fh(i-1,j,k)+fh(i+1,j,k))
|
||||
else
|
||||
fx = d2dx*(-fh(i+2,j,k)+4*fh(i+1,j,k)-3*fh(i,j,k))
|
||||
endif
|
||||
elseif(wx < 0)then
|
||||
if(i+2<=imax)then
|
||||
fx = d2dx*(-fh(i+2,j,k)+4*fh(i+1,j,k)-3*fh(i,j,k))
|
||||
elseif(i+1<=imax)then
|
||||
fx = d2dx*(-fh(i-1,j,k)+fh(i+1,j,k))
|
||||
else
|
||||
fx = d2dx*(3*fh(i,j,k)-4*fh(i-1,j,k)+fh(i-2,j,k))
|
||||
endif
|
||||
endif
|
||||
|
||||
if(wy > 0)then
|
||||
if(j-2>=jmin)then
|
||||
fy = d2dy*(3*fh(i,j,k)-4*fh(i,j-1,k)+fh(i,j-2,k))
|
||||
elseif(j-1>=jmin)then
|
||||
fy = d2dy*(-fh(i,j-1,k)+fh(i,j+1,k))
|
||||
else
|
||||
fy = d2dy*(-fh(i,j+2,k)+4*fh(i,j+1,k)-3*fh(i,j,k))
|
||||
endif
|
||||
elseif(wy < 0)then
|
||||
if(j+2<=jmax)then
|
||||
fy = d2dy*(-fh(i,j+2,k)+4*fh(i,j+1,k)-3*fh(i,j,k))
|
||||
elseif(j+1<=jmax)then
|
||||
fy = d2dy*(-fh(i,j-1,k)+fh(i,j+1,k))
|
||||
else
|
||||
fy = d2dy*(3*fh(i,j,k)-4*fh(i,j-1,k)+fh(i,j-2,k))
|
||||
endif
|
||||
endif
|
||||
|
||||
if(wz > 0)then
|
||||
if(k-2>=kmin)then
|
||||
fz = d2dz*(3*fh(i,j,k)-4*fh(i,j,k-1)+fh(i,j,k-2))
|
||||
elseif(k-1>=kmin)then
|
||||
fz = d2dz*(-fh(i,j,k-1)+fh(i,j,k+1))
|
||||
else
|
||||
fz = d2dz*(-fh(i,j,k+2)+4*fh(i,j,k+1)-3*fh(i,j,k))
|
||||
endif
|
||||
elseif(wz < 0)then
|
||||
if(k+2<=kmax)then
|
||||
fz = d2dz*(-fh(i,j,k+2)+4*fh(i,j,k+1)-3*fh(i,j,k))
|
||||
elseif(k+1<=kmax)then
|
||||
fz = d2dz*(-fh(i,j,k-1)+fh(i,j,k+1))
|
||||
else
|
||||
fz = d2dz*(3*fh(i,j,k)-4*fh(i,j,k-1)+fh(i,j,k-2))
|
||||
endif
|
||||
endif
|
||||
|
||||
f_rhs(i,j,k) = -velocity*(fx*X(i) + fy*Y(j) + fz*Z(k) + f0(i,j,k))/R
|
||||
#endif
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
|
||||
return
|
||||
|
||||
end subroutine sommerfeld_routbam
|
||||
!sommerfeld condition following BAM code for shell
|
||||
subroutine sommerfeld_routbam_ss(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,f_rhs,&
|
||||
f0,velocity,SoA,Symmetry)
|
||||
|
||||
implicit none
|
||||
|
||||
!~~~~~~> Input parameters:
|
||||
integer, intent(in):: ex(1:3),Symmetry
|
||||
real*8, intent(in) :: velocity
|
||||
real*8, dimension(ex(1)) :: X
|
||||
real*8, dimension(ex(2)) :: Y
|
||||
! Z-> R
|
||||
real*8, dimension(ex(3)) :: Z
|
||||
real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::f0
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f_rhs
|
||||
real*8,dimension(3),intent(in) ::SoA
|
||||
!~~~~~~> Other variables:
|
||||
logical :: gont
|
||||
real*8 :: dZ
|
||||
integer :: i, j, k
|
||||
real*8 :: d2dz
|
||||
integer :: layer(1:6,1:6),gp
|
||||
! index of layer, first one: i,j,k; second one: front back etc. boundary
|
||||
integer :: kmin,kmax
|
||||
real*8 :: fz
|
||||
real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0
|
||||
|
||||
dZ = Z(2) - Z(1)
|
||||
|
||||
d2dz = ONE/TWO/dZ
|
||||
|
||||
kmax = ex(3)
|
||||
|
||||
kmin = 1
|
||||
|
||||
layer(1:3,:) = 1
|
||||
layer(4:6,:) =-1
|
||||
|
||||
if(dabs(Z(ex(3))-zmax) < dZ)then
|
||||
layer(1,3) = 1
|
||||
layer(2,3) = 1
|
||||
layer(4,3) = ex(1)
|
||||
layer(5,3) = ex(2)
|
||||
#if 1
|
||||
! do not consider buffer points near boundary
|
||||
layer(3,3) = ex(3)
|
||||
layer(6,3) = ex(3)
|
||||
#else
|
||||
! consider buffer points near boundary
|
||||
layer(3,3) = ex(3) - ghost_width
|
||||
layer(6,3) = ex(3) - ghost_width
|
||||
#endif
|
||||
endif
|
||||
|
||||
if(dabs(Z(1)-zmin) < dZ)then
|
||||
layer(1,6) = 1
|
||||
layer(2,6) = 1
|
||||
layer(3,6) = 1
|
||||
layer(4,6) = ex(1)
|
||||
layer(5,6) = ex(2)
|
||||
layer(6,6) = 1
|
||||
endif
|
||||
|
||||
! outgoing BD
|
||||
gp = 3
|
||||
|
||||
gont = any( layer(:,gp) == - 1 )
|
||||
|
||||
if( .not. gont ) then
|
||||
|
||||
do k = layer(3,gp), layer(6,gp)
|
||||
do j = layer(2,gp), layer(5,gp)
|
||||
do i = layer(1,gp), layer(4,gp)
|
||||
#if 0
|
||||
!! old code
|
||||
! z direction
|
||||
if(k+1 <= kmax .and. k-1 >= kmin)then
|
||||
fz=d2dz*(-f0(i,j,k-1)+f0(i,j,k+1))
|
||||
|
||||
elseif(k==kmin)then
|
||||
fz=(-f0(i,j,k)+f0(i,j,k+1))/dZ
|
||||
|
||||
elseif(k==kmax)then
|
||||
fz=(-f0(i,j,k-1)+f0(i,j,k))/dZ
|
||||
|
||||
endif
|
||||
#else
|
||||
!! new code, 2012dec16, based on bam
|
||||
if(velocity > 0)then
|
||||
if(k-2>=kmin)then
|
||||
fz = d2dz*(3*f0(i,j,k)-4*f0(i,j,k-1)+f0(i,j,k-2))
|
||||
elseif(k-1>=kmin)then
|
||||
fz = d2dz*(-f0(i,j,k-1)+f0(i,j,k+1))
|
||||
else
|
||||
fz = d2dz*(-f0(i,j,k+2)+4*f0(i,j,k+1)-3*f0(i,j,k))
|
||||
endif
|
||||
elseif(velocity < 0)then
|
||||
if(k+2<=kmax)then
|
||||
fz = d2dz*(-f0(i,j,k+2)+4*f0(i,j,k+1)-3*f0(i,j,k))
|
||||
elseif(k+1<=kmax)then
|
||||
fz = d2dz*(-f0(i,j,k-1)+f0(i,j,k+1))
|
||||
else
|
||||
fz = d2dz*(3*f0(i,j,k)-4*f0(i,j,k-1)+f0(i,j,k-2))
|
||||
endif
|
||||
endif
|
||||
#endif
|
||||
f_rhs(i,j,k) = -velocity*(fz+f0(i,j,k)/Z(k))
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
! fix BD
|
||||
gp = 6
|
||||
|
||||
gont = any( layer(:,gp) == - 1 )
|
||||
|
||||
if( .not. gont ) then
|
||||
|
||||
do k = layer(3,gp), layer(6,gp)
|
||||
do j = layer(2,gp), layer(5,gp)
|
||||
do i = layer(1,gp), layer(4,gp)
|
||||
! z direction
|
||||
f_rhs(i,j,k) = ZEO
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
return
|
||||
|
||||
end subroutine sommerfeld_routbam_ss
|
||||
! falloff boundary condition
|
||||
subroutine falloff_ss(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,f,n,SoA,Symmetry)
|
||||
|
||||
implicit none
|
||||
|
||||
!~~~~~~> Input parameters:
|
||||
integer, intent(in):: ex(1:3),Symmetry,n
|
||||
real*8, dimension(ex(1)) :: X
|
||||
real*8, dimension(ex(2)) :: Y
|
||||
! Z-> R
|
||||
real*8, dimension(ex(3)) :: Z
|
||||
real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax
|
||||
real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f
|
||||
real*8,dimension(3),intent(in) ::SoA
|
||||
!~~~~~~> Other variables:
|
||||
logical :: gont
|
||||
real*8 :: dZ
|
||||
integer :: i, j, k
|
||||
real*8 :: d2dz
|
||||
integer :: layer(1:6,1:6),gp
|
||||
! index of layer, first one: i,j,k; second one: front back etc. boundary
|
||||
integer :: kmin,kmax
|
||||
real*8 :: fz
|
||||
real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0
|
||||
|
||||
dZ = Z(2) - Z(1)
|
||||
|
||||
d2dz = ONE/TWO/dZ
|
||||
|
||||
kmax = ex(3)
|
||||
|
||||
kmin = 1
|
||||
|
||||
layer(1:3,:) = 1
|
||||
layer(4:6,:) =-1
|
||||
|
||||
if(dabs(Z(ex(3))-zmax) < dZ)then
|
||||
layer(1,3) = 1
|
||||
layer(2,3) = 1
|
||||
layer(4,3) = ex(1)
|
||||
layer(5,3) = ex(2)
|
||||
layer(3,3) = ex(3)
|
||||
layer(6,3) = ex(3)
|
||||
endif
|
||||
|
||||
! falloff BD
|
||||
gp = 3
|
||||
|
||||
gont = any( layer(:,gp) == - 1 )
|
||||
|
||||
if( .not. gont ) then
|
||||
|
||||
do k = layer(3,gp), layer(6,gp)
|
||||
do j = layer(2,gp), layer(5,gp)
|
||||
do i = layer(1,gp), layer(4,gp)
|
||||
! z direction
|
||||
f(i,j,k) = f(i,j,k-1)*((Z(k)+Z(k-1))/n/dZ-1)/((Z(k)+Z(k-1))/n/dZ+1)
|
||||
enddo
|
||||
enddo
|
||||
enddo
|
||||
endif
|
||||
|
||||
return
|
||||
|
||||
end subroutine falloff_ss
|
||||
53
AMSS_NCKU_source/BSSN/sommerfeld_rout.h
Normal file
53
AMSS_NCKU_source/BSSN/sommerfeld_rout.h
Normal file
@@ -0,0 +1,53 @@
|
||||
|
||||
#ifndef SOMMERFELD_ROUT_H
|
||||
#define SOMMERFELD_ROUT_H
|
||||
|
||||
#ifdef fortran1
|
||||
#define f_sommerfeld_rout sommerfeld_rout
|
||||
#define f_sommerfeld_routbam sommerfeld_routbam
|
||||
#define f_sommerfeld_routbam_ss sommerfeld_routbam_ss
|
||||
#define f_falloff_ss falloff_ss
|
||||
#endif
|
||||
#ifdef fortran2
|
||||
#define f_sommerfeld_rout SOMMERFELD_ROUT
|
||||
#define f_sommerfeld_rout SOMMERFELD_ROUTBAM
|
||||
#define f_sommerfeld_rout_ss SOMMERFELD_ROUTBAM_SS
|
||||
#define f_falloff_ss FALLOFF_SS
|
||||
#endif
|
||||
#ifdef fortran3
|
||||
#define f_sommerfeld_rout sommerfeld_rout_
|
||||
#define f_sommerfeld_routbam sommerfeld_routbam_
|
||||
#define f_sommerfeld_routbam_ss sommerfeld_routbam_ss_
|
||||
#define f_falloff_ss falloff_ss_
|
||||
#endif
|
||||
|
||||
extern "C"
|
||||
{
|
||||
void f_sommerfeld_rout(int *, double *, double *, double *,
|
||||
double &, double &, double &, double &, double &, double &, double &, double *,
|
||||
double *, double *, double *, double *,
|
||||
int &, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
void f_sommerfeld_routbam(int *, double *, double *, double *,
|
||||
double &, double &, double &, double &, double &, double &, double *,
|
||||
double *, double &, double *, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
void f_sommerfeld_routbam_ss(int *, double *, double *, double *,
|
||||
double &, double &, double &, double &, double &, double &, double *,
|
||||
double *, double &, double *, int &);
|
||||
}
|
||||
|
||||
extern "C"
|
||||
{
|
||||
void f_falloff_ss(int *, double *, double *, double *,
|
||||
double &, double &, double &, double &, double &, double &, double *,
|
||||
int &, double *, int &);
|
||||
}
|
||||
|
||||
#endif /* SOMMERFELD_ROUT_H */
|
||||
74
AMSS_NCKU_source/BSSN/transpbh.C
Normal file
74
AMSS_NCKU_source/BSSN/transpbh.C
Normal file
@@ -0,0 +1,74 @@
|
||||
// $Id: transpbh.C,v 1.2 2013/04/19 03:49:25 zjcao Exp $
|
||||
#ifdef newc
|
||||
#include <iostream>
|
||||
#include <iomanip>
|
||||
#include <fstream>
|
||||
#include <cstdlib>
|
||||
#include <cstdio>
|
||||
#include <string>
|
||||
#include <cmath>
|
||||
using namespace std;
|
||||
#else
|
||||
#include <iostream.h>
|
||||
#include <iomanip.h>
|
||||
#include <fstream.h>
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include <math.h>
|
||||
#endif
|
||||
|
||||
#include "macrodef.h"
|
||||
|
||||
// transmit black hole's position from bssn class
|
||||
|
||||
int BHN;
|
||||
double Mass[3];
|
||||
double PBH[9];
|
||||
|
||||
void setpbh(int iBHN, double **iPBH, double *iMass, int rBHN)
|
||||
{
|
||||
BHN = Mymax(iBHN, rBHN);
|
||||
for (int i = 0; i < iBHN; i++)
|
||||
{
|
||||
for (int j = 0; j < 3; j++)
|
||||
PBH[3 * i + j] = iPBH[i][j];
|
||||
Mass[i] = iMass[i];
|
||||
}
|
||||
if (BHN < rBHN)
|
||||
{
|
||||
if (rBHN > 2)
|
||||
cout << "error in transpbh.C: something wrong." << endl;
|
||||
else
|
||||
{
|
||||
for (int j = 0; j < 3; j++)
|
||||
PBH[3 + j] = -iPBH[0][j];
|
||||
|
||||
Mass[1] = Mass[0];
|
||||
}
|
||||
}
|
||||
}
|
||||
extern "C"
|
||||
{
|
||||
|
||||
#ifdef fortran1
|
||||
void getpbh
|
||||
#endif
|
||||
#ifdef fortran2
|
||||
void GETPBH
|
||||
#endif
|
||||
#ifdef fortran3
|
||||
void
|
||||
getpbh_
|
||||
#endif
|
||||
(int &oBHN, double *oPBH, double *oMass)
|
||||
{
|
||||
oBHN = BHN;
|
||||
for (int i = 0; i < BHN; i++)
|
||||
oMass[i] = Mass[i];
|
||||
for (int i = 0; i < 3 * BHN; i++)
|
||||
oPBH[i] = PBH[i];
|
||||
|
||||
// printf("have set BH_num = %d\n",oBHN);
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user