asc26 amss-ncku initialized

AMSS_NCKU_source/enforce_algebra.f90

@@ -0,0 +1,198 @@
+
+!-----------------------------------------------------------------------------
+!
+! 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:
+  
+  real*8, dimension(ex(1),ex(2),ex(3)) :: trA,detg
+  real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz 
+  real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz,gupyy,gupyz,gupzz
+  real*8, parameter :: F1o3 = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0
+
+!~~~~~~>
+
+  gxx = dxx + ONE
+  gyy = dyy + ONE
+  gzz = dzz + ONE
+
+  detg =  gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
+          gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
+  gupxx =   ( gyy * gzz - gyz * gyz ) / detg
+  gupxy = - ( gxy * gzz - gyz * gxz ) / detg
+  gupxz =   ( gxy * gyz - gyy * gxz ) / detg
+  gupyy =   ( gxx * gzz - gxz * gxz ) / detg
+  gupyz = - ( gxx * gyz - gxy * gxz ) / detg
+  gupzz =   ( gxx * gyy - gxy * gxy ) / detg
+
+  trA =         gupxx * Axx + gupyy * Ayy + gupzz * Azz &
+       + TWO * (gupxy * Axy + gupxz * Axz + gupyz * Ayz)
+
+  Axx = Axx - F1o3 * gxx * trA
+  Axy = Axy - F1o3 * gxy * trA
+  Axz = Axz - F1o3 * gxz * trA
+  Ayy = Ayy - F1o3 * gyy * trA
+  Ayz = Ayz - F1o3 * gyz * trA
+  Azz = Azz - F1o3 * gzz * trA
+
+  detg = ONE / ( detg ** F1o3 ) 
+  
+  gxx = gxx * detg
+  gxy = gxy * detg
+  gxz = gxz * detg
+  gyy = gyy * detg
+  gyz = gyz * detg
+  gzz = gzz * detg
+
+  dxx = gxx - ONE
+  dyy = gyy - ONE
+  dzz = gzz - ONE
+
+  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:
+  
+  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)) :: gupxx,gupxy,gupxz,gupyy,gupyz,gupzz
+  real*8, parameter :: F1o3 = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0
+
+!~~~~~~>
+
+  gxx = dxx + ONE
+  gyy = dyy + ONE
+  gzz = dzz + ONE
+! for g
+  gupzz =  gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - &
+           gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz
+
+  gupzz = ONE / ( gupzz ** F1o3 ) 
+  
+  gxx = gxx * gupzz
+  gxy = gxy * gupzz
+  gxz = gxz * gupzz
+  gyy = gyy * gupzz
+  gyz = gyz * gupzz
+  gzz = gzz * gupzz
+
+  dxx = gxx - ONE
+  dyy = gyy - ONE
+  dzz = gzz - ONE
+! for A  
+
+  gupxx =   ( gyy * gzz - gyz * gyz )
+  gupxy = - ( gxy * gzz - gyz * gxz )
+  gupxz =   ( gxy * gyz - gyy * gxz )
+  gupyy =   ( gxx * gzz - gxz * gxz )
+  gupyz = - ( gxx * gyz - gxy * gxz )
+  gupzz =   ( gxx * gyy - gxy * gxy )
+
+  trA =         gupxx * Axx + gupyy * Ayy + gupzz * Azz &
+       + TWO * (gupxy * Axy + gupxz * Axz + gupyz * Ayz)
+
+  Axx = Axx - F1o3 * gxx * trA
+  Axy = Axy - F1o3 * gxy * trA
+  Axz = Axz - F1o3 * gxz * trA
+  Ayy = Ayy - F1o3 * gyy * trA
+  Ayz = Ayz - F1o3 * gyz * trA
+  Azz = Azz - F1o3 * gzz * trA
+
+  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