


















































































































 


































































































































































 






























































































































































































 



















































 










 








































































































































































































































 










                                
                                

                                
                                

                                
                                

                                







































































c

      SUBROUTINE D3_to_D2(cctkGH,conformal_state,do_ADMmass,do_momentum,
     &do_spin,
     &     Psi_power,origin,myproc,interpolation_operator,interpolation_
     &order,
     &     Dx,Dy,Dz,Psi,
     &     g00,gxx,gxy,gxz,gyy,gyz,gzz,hxx,hxy,hxz,hyy,hyz,hzz,
     &     x,y,z,eta,Nt,Np,nx,ny,nz,theta,phi,
     &     Psis,g00s,gxxs,gxys,gxzs,gyys,gyzs,gzzs,dPsis,dgxxs,dgxys,dgx
     &zs,
     &     dgyys,dgyzs,dgzzs,ADMmass_int1,ADMmass_int2,
     &     momentum_int1,momentum_int2,momentum_int3,
     &     spin_int1,spin_int2,spin_int3,Extract_temp3d)

c
c
c
c
c

      USE met_rad_der_int
      USE ADMmass_integrand3D_int
      USE momentum_integrand3D_int
      USE spin_integrand3D_int

      IMPLICIT NONE

      interface
      integer*8 function CCTK_PointerTo (var)
      implicit none
      type(*),dimension(..),TARGET :: var
      end function CCTK_PointerTo
      end interface
      interface
      integer function CCTK_Equals (arg1, arg2)
      implicit none
      integer*8 arg1
      character(*) arg2
      end function CCTK_Equals
      integer function CCTK_MyProc (cctkGH)
      implicit none
      integer*8 cctkGH
      end function CCTK_MyProc
      integer function CCTK_nProcs (cctkGH)
      implicit none
      integer*8 cctkGH
      end function CCTK_nProcs
      integer function CCTK_IsThornActive (name)
      implicit none
      character(*) name
      end function CCTK_IsThornActive
      integer*8 function CCTK_NullPointer ()
      implicit none
      end function CCTK_NullPointer
      end interface

c

      integer*8 :: cctkGH

      INTEGER*4,INTENT(IN) ::
     &     conformal_state
      INTEGER,INTENT(IN) ::
     &     myproc,Psi_power
      INTEGER*4, INTENT(IN) ::
     &     Nt,Np,nx,ny,nz,do_momentum,do_spin,interpolation_order
      REAL*8,INTENT(IN) ::
     &     origin(3),Dx,Dy,Dz,eta
      REAL*8,INTENT(IN),DIMENSION(Nt) :: theta
      REAL*8,INTENT(IN),DIMENSION(Np) :: phi
      REAL*8,INTENT(IN),DIMENSION(nx) :: x
      REAL*8,INTENT(IN),DIMENSION(ny) :: y
      REAL*8,INTENT(IN),DIMENSION(nz) :: z
      REAL*8,INTENT(IN),DIMENSION(nx,ny,nz) ::
     &     Psi,g00,gxx,gxy,gxz,gyy,gyz,gzz,
     &     hxx,hxy,hxz,hyy,hyz,hzz
      INTEGER,INTENT(IN) :: do_ADMmass(2)
      integer*8,INTENT(IN) :: 
     &     interpolation_operator
      REAL*8,INTENT(INOUT),DIMENSION(nx,ny,nz) ::
     &     Extract_temp3d

c

      REAL*8,INTENT(OUT),DIMENSION(Nt,Np) ::
     &     Psis,g00s,gxxs,gxys,gxzs,gyys,
     &     gyzs,gzzs,dPsis,dgxxs,dgxys,dgxzs,dgyys,dgyzs,dgzzs,
     &     ADMmass_int1,ADMmass_int2,
     &     momentum_int1,momentum_int2,momentum_int3,
     &     spin_int1,spin_int2,spin_int3


c

      LOGICAL ::
     &    err_flag
      INTEGER ::
     &    iorder,npoints
      INTEGER,DIMENSION(Nt,Np) ::
     &    ib,jb,kb
      REAL*8,DIMENSION(Nt,Np) ::
     &    xs,ys,zs,ux,uy,uz,xb,yb,zb

c

      INTEGER :: i, j, num_arrays, vindex, ierror
      INTEGER :: interp_handle, param_table_handle, coord_system_handle
      integer*8, dimension(3) :: interp_coords
      INTEGER*4,  dimension(8)    :: in_array_indices
      integer*8, dimension(8) :: out_arrays
      INTEGER*4, dimension(8)     :: out_array_type_codes

      character(128) options_string
      character(128) operator
      INTEGER*4 nchars
      character(len=20) :: error_code

c

c
c
c
c
      DO j = 1, Np
         DO i = 1, Nt

            xs(i,j) = origin(1)+eta*SIN(theta(i))*COS(phi(j))
            ys(i,j) = origin(2)+eta*SIN(theta(i))*SIN(phi(j))
            zs(i,j) = origin(3)+eta*COS(theta(i))

         ENDDO
      ENDDO

c

c
c
      SELECT CASE (myproc)

      CASE (0)
         npoints = Np*Nt

      CASE DEFAULT
         npoints = 0

      END SELECT

c

c
c
      interp_handle = -1
      param_table_handle = -1
      coord_system_handle = -1


      call CCTK_FortranString(nchars,interpolation_operator,operator)
      call CCTK_InterpHandle (interp_handle,operator)
      if (interp_handle .lt. 0) then
        call CCTK_Warn(0,135,"D3_to_D2.F","Extract","Cannot get handle f
     &or interpolation ! Forgot to activate an implementation providing 
     &interpolation operators ??")
      endif

      options_string = "order = " // char(ichar('0') + interpolation_ord
     &er)
      call Util_TableCreateFromString (param_table_handle, options_strin
     &g)
      if (param_table_handle .lt. 0) then
        call CCTK_Warn(0,141,"D3_to_D2.F","Extract","Cannot create param
     &eter table for interpolator")
      endif

      call CCTK_CoordSystemHandle (coord_system_handle, "cart3d")
      if (coord_system_handle .lt. 0) then
        call CCTK_Warn(0,146,"D3_to_D2.F","Extract","Cannot get handle f
     &or cart3d coordinate system ! Forgot to activate an implementation
     & providing coordinates ??")
      endif

c

c
c
      interp_coords(1) = CCTK_PointerTo(xs)
      interp_coords(2) = CCTK_PointerTo(ys)
      interp_coords(3) = CCTK_PointerTo(zs)

      call CCTK_VarIndex(vindex, "extract::g00")
      in_array_indices(1) = vindex
      call CCTK_VarIndex(vindex, "admbase::gxx")
      in_array_indices(2) = vindex
      call CCTK_VarIndex(vindex, "admbase::gxy")
      in_array_indices(3) = vindex
      call CCTK_VarIndex(vindex, "admbase::gxz")
      in_array_indices(4) = vindex
      call CCTK_VarIndex(vindex, "admbase::gyy")
      in_array_indices(5) = vindex
      call CCTK_VarIndex(vindex, "admbase::gyz")
      in_array_indices(6) = vindex
      call CCTK_VarIndex(vindex, "admbase::gzz")
      in_array_indices(7) = vindex
      call CCTK_VarIndex(vindex, "staticconformal::psi")
      in_array_indices(8) = vindex

      out_arrays(1) = CCTK_PointerTo(g00s)
      out_arrays(2) = CCTK_PointerTo(gxxs)
      out_arrays(3) = CCTK_PointerTo(gxys)
      out_arrays(4) = CCTK_PointerTo(gxzs)
      out_arrays(5) = CCTK_PointerTo(gyys)
      out_arrays(6) = CCTK_PointerTo(gyzs)
      out_arrays(7) = CCTK_PointerTo(gzzs)
      out_arrays(8) = CCTK_PointerTo(Psis)

      out_array_type_codes = 130


c
c
      if (conformal_state > 0) then
        num_arrays = 8
      else
        num_arrays = 7
      end if

c
c
c
      call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                            param_table_handle, coord_system_handl
     &e,
     $                            npoints, 130, interp_coords,
     $                            num_arrays, in_array_indices,
     $                            num_arrays, out_array_type_codes, out_
     &arrays)
c
      if (ierror < 0) then
        call CCTK_Warn(1,204,"D3_to_D2.F","Extract", "interpolator call 
     &returned an error code")
        write(error_code,'(a7,i13)') 'code = ',ierror
        call CCTK_Warn(1,206,"D3_to_D2.F","Extract", error_code )
      endif


c
c
      call CCTK_VarIndex(vindex, "extract::temp3d")
      in_array_indices(1) = vindex

      if (conformal_state > 0) then
c
         CALL met_rad_der(origin,Dx,Dy,Dz,x,y,z,Psi,Extract_temp3d)
c
         CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")

         out_arrays(1) = CCTK_PointerTo(dPsis)
c
c
c
         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                               param_table_handle, coord_system_ha
     &ndle,
     $                               npoints, 130, interp_coords,
     $                               1, in_array_indices(1),
     $                               1, out_array_type_codes, out_arrays
     &(1))
c
         if (ierror < 0) then
           call CCTK_Warn(1,232,"D3_to_D2.F","Extract", "interpolator ca
     &ll returned an error code")
           write(error_code,'(a7,i13)') 'code = ',ierror
           call CCTK_Warn(1,234,"D3_to_D2.F","Extract", error_code )
         endif
      end if

c
      CALL met_rad_der(origin,Dx,Dy,Dz,x,y,z,gxx,Extract_temp3d)
c
c
      CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")
c

      out_arrays(1) = CCTK_PointerTo(dgxxs)
c
c
c
      call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                            param_table_handle, coord_system_handl
     &e,
     $                            npoints, 130, interp_coords,
     $                            1, in_array_indices(1),
     $                            1, out_array_type_codes, out_arrays(1)
     &)
c
      if (ierror < 0) then
        call CCTK_Warn(1,256,"D3_to_D2.F","Extract", "interpolator call 
     &returned an error code")
        write(error_code,'(a7,i13)') 'code = ',ierror
        call CCTK_Warn(1,258,"D3_to_D2.F","Extract", error_code )
      endif

      CALL met_rad_der(origin,Dx,Dy,Dz,x,y,z,gxy,Extract_temp3d)
      CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")

      out_arrays(1) = CCTK_PointerTo(dgxys)
c
c
c
      call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                            param_table_handle, coord_system_handl
     &e,
     $                            npoints, 130, interp_coords,
     $                            1, in_array_indices(1),
     $                            1, out_array_type_codes, out_arrays(1)
     &)
c
      if (ierror < 0) then
        call CCTK_Warn(1,275,"D3_to_D2.F","Extract", "interpolator call 
     &returned an error code")
        write(error_code,'(a7,i13)') 'code = ',ierror
        call CCTK_Warn(1,277,"D3_to_D2.F","Extract", error_code )
      endif

      CALL met_rad_der(origin,Dx,Dy,Dz,x,y,z,gxz,Extract_temp3d)
      CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")

      out_arrays(1) = CCTK_PointerTo(dgxzs)
c
c
c
      call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                            param_table_handle, coord_system_handl
     &e,
     $                            npoints, 130, interp_coords,
     $                            1, in_array_indices(1),
     $                            1, out_array_type_codes, out_arrays(1)
     &)
c
      if (ierror < 0) then
        call CCTK_Warn(1,294,"D3_to_D2.F","Extract", "interpolator call 
     &returned an error code")
        write(error_code,'(a7,i13)') 'code = ',ierror
        call CCTK_Warn(1,296,"D3_to_D2.F","Extract", error_code )
      endif

      CALL met_rad_der(origin,Dx,Dy,Dz,x,y,z,gyy,Extract_temp3d)
      CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")

      out_arrays(1) = CCTK_PointerTo(dgyys)
      call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                            param_table_handle, coord_system_handl
     &e,
     $                            npoints, 130, interp_coords,
     $                            1, in_array_indices(1),
     $                            1, out_array_type_codes, out_arrays(1)
     &)
      if (ierror < 0) then
        call CCTK_Warn(1,309,"D3_to_D2.F","Extract", "interpolator call 
     &returned an error code")
        write(error_code,'(a7,i13)') 'code = ',ierror
        call CCTK_Warn(1,311,"D3_to_D2.F","Extract", error_code )
      endif

      CALL met_rad_der(origin,Dx,Dy,Dz,x,y,z,gyz,Extract_temp3d)
      CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")

      out_arrays(1) = CCTK_PointerTo(dgyzs)
c
c
c
      call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                            param_table_handle, coord_system_handl
     &e,
     $                            npoints, 130, interp_coords,
     $                            1, in_array_indices(1),
     $                            1, out_array_type_codes, out_arrays(1)
     &)
c
      if (ierror < 0) then
        call CCTK_Warn(1,328,"D3_to_D2.F","Extract", "interpolator call 
     &returned an error code")
        write(error_code,'(a7,i13)') 'code = ',ierror
        call CCTK_Warn(1,330,"D3_to_D2.F","Extract", error_code )
      endif

      CALL met_rad_der(origin,Dx,Dy,Dz,x,y,z,gzz,Extract_temp3d)
      CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")

      out_arrays(1) = CCTK_PointerTo(dgzzs)
c
c
c
      call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                            param_table_handle, coord_system_handl
     &e,
     $                            npoints, 130, interp_coords,
     $                            1, in_array_indices(1),
     $                            1, out_array_type_codes, out_arrays(1)
     &)
c
      if (ierror < 0) then
        call CCTK_Warn(1,347,"D3_to_D2.F","Extract", "interpolator call 
     &returned an error code")
        write(error_code,'(a7,i13)') 'code = ',ierror
        call CCTK_Warn(1,349,"D3_to_D2.F","Extract", error_code )
      endif


c
c
c
      IF (do_ADMmass(1) == 1) THEN
c
c
c
         CALL ADMmass_integrand3D(origin,Dx,Dy,Dz,x,y,z,gxx,gxy,
     &        gxz,gyy,gyz,gzz,Extract_temp3d,Psi,Psi_power,conformal_sta
     &te)
         CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")
c

         out_arrays(1) = CCTK_PointerTo(ADMmass_int1)
c
c
c
         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                               param_table_handle, coord_system_ha
     &ndle,
     $                               npoints, 130, interp_coords,
     $                               1, in_array_indices(1),
     $                               1, out_array_type_codes, out_arrays
     &(1))
c
         if (ierror < 0) then
           call CCTK_Warn(1,376,"D3_to_D2.F","Extract", "interpolator ca
     &ll returned an error code")
           write(error_code,'(a7,i13)') 'code = ',ierror
           call CCTK_Warn(1,378,"D3_to_D2.F","Extract", error_code )
         endif
      END IF

c
      IF (do_ADMmass(2) == 1) THEN
             ADMmass_int2 = -eta**2/2D0/3.1416D0*dPsis
      ENDIF

c
c
      IF (do_momentum==1) THEN

c
c
c
         CALL momentum_integrand3D(origin,Dx,Dy,Dz,x,y,z,
     &        gxx,gxy,gxz,gyy,gyz,gzz,hxx,hxy,hxz,hyy,hyz,hzz,
     &        Extract_temp3d,Psi,Psi_power,conformal_state)
         CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")
c

         out_arrays(1) = CCTK_PointerTo(momentum_int1)
c
c
c
         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                               param_table_handle, coord_system_ha
     &ndle,
     $                               npoints, 130, interp_coords,
     $                               1, in_array_indices(1),
     $                               1, out_array_type_codes, out_arrays
     &(1))
c
         if (ierror < 0) then
           call CCTK_Warn(1,411,"D3_to_D2.F","Extract", "interpolator ca
     &ll returned an error code")
           write(error_code,'(a7,i13)') 'code = ',ierror
           call CCTK_Warn(1,413,"D3_to_D2.F","Extract", error_code )
         endif

c
c
c
         CALL momentum_integrand3D(origin,Dx,Dy,Dz,x,y,z,
     &        gxx,gxy,gxz,gyy,gyz,gzz,hxx,hxy,hxz,hyy,hyz,hzz,
     &        Extract_temp3d,Psi,Psi_power,conformal_state)
         CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")
c

         out_arrays(1) = CCTK_PointerTo(momentum_int2)
c
c
c
         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                               param_table_handle, coord_system_ha
     &ndle,
     $                               npoints, 130, interp_coords,
     $                               1, in_array_indices(1),
     $                               1, out_array_type_codes, out_arrays
     &(1))
c
         if (ierror < 0) then
           call CCTK_Warn(1,436,"D3_to_D2.F","Extract", "interpolator ca
     &ll returned an error code")
           write(error_code,'(a7,i13)') 'code = ',ierror
           call CCTK_Warn(1,438,"D3_to_D2.F","Extract", error_code )
         endif

c
c
c
         CALL momentum_integrand3D(origin,Dx,Dy,Dz,x,y,z,
     &        gxx,gxy,gxz,gyy,gyz,gzz,hxx,hxy,hxz,hyy,hyz,hzz,
     &        Extract_temp3d,Psi,Psi_power,conformal_state)
         CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")
c

         out_arrays(1) = CCTK_PointerTo(momentum_int3)
c
c
c
         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                               param_table_handle, coord_system_ha
     &ndle,
     $                               npoints, 130, interp_coords,
     $                               1, in_array_indices(1),
     $                               1, out_array_type_codes, out_arrays
     &(1))
c
         if (ierror < 0) then
           call CCTK_Warn(1,461,"D3_to_D2.F","Extract", "interpolator ca
     &ll returned an error code")
           write(error_code,'(a7,i13)') 'code = ',ierror
           call CCTK_Warn(1,463,"D3_to_D2.F","Extract", error_code )
         endif
      END IF

c
c
      IF (do_spin==1) THEN

c
c
c
         CALL spin_integrand3D(origin,x,y,z,
     &        gxx,gxy,gxz,gyy,gyz,gzz,hxx,hxy,hxz,hyy,hyz,hzz,
     &        Extract_temp3d,Psi,Psi_power,conformal_state)
         CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")
c

         out_arrays(1) = CCTK_PointerTo(spin_int1)
c
c
c
         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                               param_table_handle, coord_system_ha
     &ndle,
     $                               npoints, 130, interp_coords,
     $                               1, in_array_indices(1),
     $                               1, out_array_type_codes, out_arrays
     &(1))
c
         if (ierror < 0) then
           call CCTK_Warn(1,491,"D3_to_D2.F","Extract", "interpolator ca
     &ll returned an error code")
           write(error_code,'(a7,i13)') 'code = ',ierror
           call CCTK_Warn(1,493,"D3_to_D2.F","Extract", error_code )
         endif

c
c
c
         CALL spin_integrand3D(origin,x,y,z,
     &        gxx,gxy,gxz,gyy,gyz,gzz,hxx,hxy,hxz,hyy,hyz,hzz,
     &        Extract_temp3d,Psi,Psi_power,conformal_state)
         CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")
c

         out_arrays(1) = CCTK_PointerTo(spin_int2)
c
c
c
         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                               param_table_handle, coord_system_ha
     &ndle,
     $                               npoints, 130, interp_coords,
     $                               1, in_array_indices(1),
     $                               1, out_array_type_codes, out_arrays
     &(1))
c
         if (ierror < 0) then
           call CCTK_Warn(1,516,"D3_to_D2.F","Extract", "interpolator ca
     &ll returned an error code")
           write(error_code,'(a7,i13)') 'code = ',ierror
           call CCTK_Warn(1,518,"D3_to_D2.F","Extract", error_code )
         endif

c
c
c
         CALL spin_integrand3D(origin,x,y,z,
     &        gxx,gxy,gxz,gyy,gyz,gzz,hxx,hxy,hxz,hyy,hyz,hzz,
     &        Extract_temp3d,Psi,Psi_power,conformal_state)
         CALL CCTK_SyncGroup(ierror,cctkGH,"extract::temps")
c

         out_arrays(1) = CCTK_PointerTo(spin_int3)
c
c
c
         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     $                               param_table_handle, coord_system_ha
     &ndle,
     $                               npoints, 130, interp_coords,
     $                               1, in_array_indices(1),
     $                               1, out_array_type_codes, out_arrays
     &(1))
c
         if (ierror < 0) then
           call CCTK_Warn(1,541,"D3_to_D2.F","Extract", "interpolator ca
     &ll returned an error code")
           write(error_code,'(a7,i13)') 'code = ',ierror
           call CCTK_Warn(1,543,"D3_to_D2.F","Extract", error_code )
         endif

      END IF

      call Util_TableDestroy (ierror, param_table_handle)

      END SUBROUTINE D3_to_D2
