Task: Implement GRHydro_P2C2P.F90 for EinsteinEvolve/GRHydro_InitData thorn

thorn_name: EinsteinEvolve/GRHydro_InitData
src_filename: GRHydro_P2C2P.F90
interface: # Interface definition for thorn GRHydro_Init_Data
# $Header$

implements: GRHydro_init_data
inherits: GRHydro grid EOS_Omni

#USES INCLUDE: EOS_Base.inc
USES INCLUDE: SpaceMask.h
#USES INCLUDE: EOS_Base.h


SUBROUTINE SpatialDet(CCTK_REAL IN gxx, CCTK_REAL IN gxy, \
                      CCTK_REAL IN gxz, CCTK_REAL IN gyy, \
		      CCTK_REAL IN gyz, CCTK_REAL IN gzz, \
		      CCTK_REAL OUT det)

SUBROUTINE Prim2ConPoly(CCTK_INT IN handle, \
                        CCTK_REAL IN gxx, CCTK_REAL IN gxy, CCTK_REAL IN gxz, \
			CCTK_REAL IN gyy, CCTK_REAL IN gyz, CCTK_REAL IN gzz, \
			CCTK_REAL IN det, CCTK_REAL OUT dens, \
			CCTK_REAL OUT sx, CCTK_REAL OUT sy, \
			CCTK_REAL OUT sz, CCTK_REAL OUT tau, \
			CCTK_REAL IN rho, CCTK_REAL IN velx, \
			CCTK_REAL IN vely, \
			CCTK_REAL IN velz, CCTK_REAL OUT epsilon, \
			CCTK_REAL OUT press, CCTK_REAL OUT w_lorentz)


SUBROUTINE Prim2ConGen(CCTK_INT IN handle, \
                          CCTK_REAL IN gxx, CCTK_REAL IN gxy, \
                          CCTK_REAL IN gxz, CCTK_REAL IN gyy, \
                          CCTK_REAL IN gyz, CCTK_REAL IN gzz, \
                          CCTK_REAL IN det, CCTK_REAL OUT dens, \
                          CCTK_REAL OUT sx, CCTK_REAL OUT sy, \
                          CCTK_REAL OUT sz, CCTK_REAL OUT tau, \
                          CCTK_REAL IN rho, CCTK_REAL IN velx, \
                          CCTK_REAL IN vely, \
                          CCTK_REAL IN velz, CCTK_REAL IN epsilon, \
                          CCTK_REAL OUT press, CCTK_REAL OUT w_lorentz)

SUBROUTINE Prim2ConPolyM(CCTK_INT IN handle, \
                           CCTK_REAL IN gxx, CCTK_REAL IN gxy, \
                           CCTK_REAL IN gxz, CCTK_REAL IN gyy, \
                           CCTK_REAL IN gyz, CCTK_REAL IN gzz, \
                           CCTK_REAL IN det, CCTK_REAL OUT dens, \
                           CCTK_REAL OUT sx, CCTK_REAL OUT sy, \
                           CCTK_REAL OUT sz, CCTK_REAL OUT tau, \
                           CCTK_REAL OUT Bconsx, CCTK_REAL OUT Bconsy, \
                           CCTK_REAL OUT Bconsz, CCTK_REAL IN rho, CCTK_REAL IN velx, \
                           CCTK_REAL IN vely, \
                           CCTK_REAL IN velz, CCTK_REAL OUT epsilon, \
                           CCTK_REAL OUT press,  CCTK_REAL IN Bvecx, CCTK_REAL IN Bvecy, \
                           CCTK_REAL IN Bvecz, CCTK_REAL OUT w_lorentz)

SUBROUTINE Prim2ConGenM(CCTK_INT IN handle, \
                          CCTK_REAL IN gxx, CCTK_REAL IN gxy, \
                          CCTK_REAL IN gxz, CCTK_REAL IN gyy, \
                          CCTK_REAL IN gyz, CCTK_REAL IN gzz, \
                          CCTK_REAL IN det, CCTK_REAL OUT dens, \
                          CCTK_REAL OUT sx, CCTK_REAL OUT sy, \
                          CCTK_REAL OUT sz, CCTK_REAL OUT tau, \
                          CCTK_REAL OUT Bconsx, CCTK_REAL OUT Bconsy, \
                          CCTK_REAL OUT Bconsz, CCTK_REAL IN rho, CCTK_REAL IN velx, \
                          CCTK_REAL IN vely, \
                          CCTK_REAL IN velz, CCTK_REAL IN epsilon, \
                          CCTK_REAL OUT press, CCTK_REAL IN Bvecx, CCTK_REAL IN Bvecy, \
                          CCTK_REAL IN Bvecz, CCTK_REAL OUT w_lorentz)

SUBROUTINE Prim2ConGenM_hot(CCTK_INT IN handle, CCTK_INT IN GRHydro_reflevel, CCTK_INT IN i, CCTK_INT IN j, CCTK_INT IN k, \
                          CCTK_REAL IN x, CCTK_REAL IN y, CCTK_REAL IN z, \
                          CCTK_REAL IN gxx, CCTK_REAL IN gxy, \
                          CCTK_REAL IN gxz, CCTK_REAL IN gyy, \
                          CCTK_REAL IN gyz, CCTK_REAL IN gzz, \
                          CCTK_REAL IN det, CCTK_REAL OUT dens, \
                          CCTK_REAL OUT sx, CCTK_REAL OUT sy, \
                          CCTK_REAL OUT sz, CCTK_REAL OUT tau, \
                          CCTK_REAL OUT Bconsx, CCTK_REAL OUT Bconsy, \
                          CCTK_REAL OUT Bconsz, CCTK_REAL IN rho, CCTK_REAL IN velx, \
                          CCTK_REAL IN vely, \
                          CCTK_REAL IN velz, CCTK_REAL IN epsilon, \
                          CCTK_REAL OUT press, CCTK_REAL IN Bvecx, CCTK_REAL IN Bvecy, \
                          CCTK_REAL IN Bvecz, CCTK_REAL OUT w_lorentz, \
                          CCTK_REAL INOUT temperature, CCTK_REAL IN Y_e)


SUBROUTINE Con2PrimPoly(CCTK_INT IN handle, CCTK_REAL INOUT dens, \
                           CCTK_REAL INOUT sx, CCTK_REAL INOUT sy, \
                           CCTK_REAL INOUT sz, CCTK_REAL OUT tau, \
                           CCTK_REAL INOUT rho, CCTK_REAL INOUT velx, \
                           CCTK_REAL INOUT vely, CCTK_REAL INOUT velz, \
                           CCTK_REAL INOUT epsilon, CCTK_REAL INOUT press, \
                           CCTK_REAL INOUT w_lorentz, CCTK_REAL IN uxx, \
                           CCTK_REAL IN uxy, CCTK_REAL IN uxz, \
                           CCTK_REAL IN uyy, CCTK_REAL IN uyz, \
                           CCTK_REAL IN uzz, CCTK_REAL IN det, \
                           CCTK_REAL IN x, CCTK_REAL IN y, CCTK_REAL IN z, \
                           CCTK_REAL IN r, CCTK_REAL IN rho_min, \
			   CCTK_INT IN GRHydro_reflevel, CCTK_REAL OUT GRHydro_C2P_failed)


void FUNCTION Con2PrimGen(CCTK_INT IN handle, CCTK_REAL INOUT dens, \
                           CCTK_REAL INOUT sx, CCTK_REAL INOUT sy, CCTK_REAL INOUT sz, \
                           CCTK_REAL INOUT tau, CCTK_REAL INOUT rho, \
                           CCTK_REAL INOUT velx, CCTK_REAL INOUT vely, CCTK_REAL INOUT velz, \
                           CCTK_REAL INOUT epsilon, CCTK_REAL INOUT pressure, \
                           CCTK_REAL INOUT w_lorentz, \
                           CCTK_REAL IN uxx, CCTK_REAL IN uxy, CCTK_REAL IN uxz, \
                           CCTK_REAL IN uyy, CCTK_REAL IN uyz, CCTK_REAL IN uzz, \
                           CCTK_REAL IN det, \
                           CCTK_REAL IN x, CCTK_REAL IN y, CCTK_REAL IN z, \
                           CCTK_REAL IN r, \
                           CCTK_INT OUT epsnegative, \
		           CCTK_REAL IN GRHydro_rho_min, CCTK_REAL IN pmin, \
		           CCTK_REAL IN epsmin, \
                           CCTK_INT IN GRHydro_reflevel, \
                           CCTK_REAL OUT retval)

void FUNCTION Con2PrimGenM(CCTK_INT IN handle, CCTK_INT IN keytemp, CCTK_REAL IN prec,CCTK_REAL IN gamma_eos, CCTK_REAL INOUT dens, \
                           CCTK_REAL INOUT sx, CCTK_REAL INOUT sy, CCTK_REAL INOUT sz, \
                           CCTK_REAL INOUT tau, CCTK_REAL IN Bconsx, CCTK_REAL IN Bconsy, CCTK_REAL IN Bconsz, \
			   CCTK_REAL INOUT y_e,  CCTK_REAL INOUT temp,  CCTK_REAL INOUT rho, \
                           CCTK_REAL INOUT velx, CCTK_REAL INOUT vely, CCTK_REAL INOUT velz, \
                           CCTK_REAL INOUT epsilon, CCTK_REAL INOUT pressure, \
                           CCTK_REAL OUT Bvecx, CCTK_REAL OUT Bvecy, CCTK_REAL OUT Bvecz, \
                           CCTK_REAL OUT bvecsq, \
                           CCTK_REAL INOUT w_lorentz, \
                           CCTK_REAL IN gxx, CCTK_REAL IN gxy, CCTK_REAL IN gxz, \
                           CCTK_REAL IN gyy, CCTK_REAL IN gyz, CCTK_REAL IN gzz, \
                           CCTK_REAL IN uxx, CCTK_REAL IN uxy, CCTK_REAL IN uxz, \
                           CCTK_REAL IN uyy, CCTK_REAL IN uyz, CCTK_REAL IN uzz, \
                           CCTK_REAL IN det, \
                           CCTK_INT OUT epsnegative, \
                           CCTK_REAL OUT retval)

void FUNCTION Con2PrimGenMee(CCTK_INT IN handle, CCTK_INT IN keytemp, \
     CCTK_REAL IN prec, CCTK_REAL IN gamma_eos, \
     CCTK_REAL INOUT dens, \
     CCTK_REAL INOUT sx, CCTK_REAL INOUT sy, CCTK_REAL INOUT sz, \
     CCTK_REAL INOUT tau, \
     CCTK_REAL IN Bconsx, CCTK_REAL IN Bconsy, CCTK_REAL IN Bconsz, \
     CCTK_REAL INOUT entropycons, \
     CCTK_REAL INOUT y_e, CCTK_REAL INOUT temp, CCTK_REAL INOUT rho, \
     CCTK_REAL INOUT velx, CCTK_REAL INOUT vely, CCTK_REAL INOUT velz, \
     CCTK_REAL INOUT epsilon, CCTK_REAL INOUT pressure, \
     CCTK_REAL OUT Bvecx, CCTK_REAL OUT Bvecy, CCTK_REAL OUT Bvecz, \
     CCTK_REAL OUT Bvecsq, \
     CCTK_REAL INOUT w_lorentz, \
     CCTK_REAL IN gxx, CCTK_REAL IN gxy, CCTK_REAL IN gxz, \
     CCTK_REAL IN gyy, CCTK_REAL IN gyz, CCTK_REAL IN gzz, \
     CCTK_REAL IN uxx, CCTK_REAL IN uxy, CCTK_REAL IN uxz, \
     CCTK_REAL IN uyy, CCTK_REAL IN uyz, CCTK_REAL IN uzz, \
     CCTK_REAL IN det, \
     CCTK_INT OUT epsnegative, \
     CCTK_REAL OUT retval)

void FUNCTION Con2PrimPolyM(CCTK_INT IN handle, CCTK_REAL IN gamma_eos, CCTK_REAL INOUT dens, \
                           CCTK_REAL INOUT sx, CCTK_REAL INOUT sy, CCTK_REAL INOUT sz, \
                           CCTK_REAL INOUT sc, CCTK_REAL IN Bconsx, CCTK_REAL IN Bconsy, CCTK_REAL IN Bconsz, \
			   CCTK_REAL INOUT rho, \
                           CCTK_REAL INOUT velx, CCTK_REAL INOUT vely, CCTK_REAL INOUT velz, \
                           CCTK_REAL INOUT epsilon, CCTK_REAL INOUT pressure, \
                           CCTK_REAL OUT Bvecx, CCTK_REAL OUT Bvecy, CCTK_REAL OUT Bvecz, \
                           CCTK_REAL OUT Bvecsq, \
                           CCTK_REAL INOUT w_lorentz, \
                           CCTK_REAL IN gxx, CCTK_REAL IN gxy, CCTK_REAL IN gxz, \
                           CCTK_REAL IN gyy, CCTK_REAL IN gyz, CCTK_REAL IN gzz, \
                           CCTK_REAL IN uxx, CCTK_REAL IN uxy, CCTK_REAL IN uxz, \
                           CCTK_REAL IN uyy, CCTK_REAL IN uyz, CCTK_REAL IN uzz, \
                           CCTK_REAL IN det, \
                           CCTK_INT OUT epsnegative, \
                           CCTK_REAL OUT retval)

USES FUNCTION SpatialDet
USES FUNCTION Prim2ConPoly
USES FUNCTION Prim2ConGen
USES FUNCTION Prim2ConPolyM
USES FUNCTION Prim2ConGenM
USES FUNCTION Prim2ConGenM_hot
USES FUNCTION Con2PrimPoly
USES FUNCTION Con2PrimGen
USES FUNCTION Con2PrimGenM
USES FUNCTION Con2PrimGenMee
USES FUNCTION Con2PrimPolyM

CCTK_INT FUNCTION EOS_Omni_GetHandle(CCTK_STRING IN name)
USES FUNCTION EOS_Omni_GetHandle


void FUNCTION EOS_Omni_press(CCTK_INT IN eoshandle,      \
                             CCTK_INT IN havetemp,       \
			     CCTK_REAL IN rf_precision,  \
                             CCTK_INT IN npoints,        \
                             CCTK_REAL IN ARRAY rho,     \
                             CCTK_REAL INOUT ARRAY eps,  \
                             CCTK_REAL INOUT ARRAY temp, \
                             CCTK_REAL IN ARRAY ye,      \
                             CCTK_REAL OUT ARRAY press,  \
                             CCTK_INT OUT ARRAY keyerr,  \
                             CCTK_INT OUT anyerr)

USES FUNCTION EOS_Omni_press

void FUNCTION EOS_Omni_EpsFromPress(CCTK_INT IN eoshandle,      \
                             CCTK_INT IN havetemp,              \
			     CCTK_REAL IN rf_precision,         \
                             CCTK_INT IN npoints,               \
                             CCTK_REAL IN ARRAY rho,            \
                             CCTK_REAL INOUT ARRAY eps,         \
                             CCTK_REAL INOUT ARRAY temp,        \
                             CCTK_REAL IN ARRAY ye,             \
                             CCTK_REAL IN ARRAY press,          \
                             CCTK_REAL OUT ARRAY xeps,          \
                             CCTK_INT OUT ARRAY keyerr,         \
                             CCTK_INT OUT anyerr)

USES FUNCTION EOS_Omni_EpsFromPress



protected:

CCTK_REAL simple_wave_grid_functions TYPE=GF TIMELEVELS=1 tags='checkpoint="no"'
{
  simple_tmp
  c_s
} "1D arrays for the simple-wave routine"

CCTK_REAL simple_wave_scalars TYPE=scalar
{
     simple_rho_0
     simple_eps_0
} "values at v=0"

CCTK_REAL simple_wave_output TYPE=GF TIMELEVELS=1 tags='checkpoint="no"'
{
  simple_rho
  simple_eps
#  simple_entropy
} "output variables for the simple-wave routine"

private:

CCTK_INT GRHydro_init_data_reflevel type = SCALAR tags='checkpoint="no"' "Refinement level GRHydro is working on right now"

schedule: # Schedule definitions for thorn GRHydro_Init_Data

schedule GRHydro_InitData_CheckParameters  AT CCTK_PARAMCHECK
{
  LANG: C
} "Check parameters"

if (CCTK_Equals(initial_hydro,"monopole")) {
  schedule GRHydro_MonopoleM in HydroBase_Initial
    {
      LANG: Fortran
    } "Monopole initial data"
}

if (CCTK_Equals(initial_hydro,"rotor")) {
  schedule GRHydro_RotorM in HydroBase_Initial
    {
      LANG: Fortran
    } "MHD rotor initial data"
}

if (CCTK_Equals(initial_hydro,"advectedloop")) {
  schedule GRHydro_AdvectedLoopM in HydroBase_Initial
    {
      LANG: Fortran
    } "MHD advected loop initial data"
}

if (CCTK_Equals(initial_hydro,"alfvenwave")) {
  schedule GRHydro_AlfvenWaveM in HydroBase_Initial
    {
      LANG: Fortran
    } "Circularly polarized Alfven wave initial data"
}

if (CCTK_Equals(initial_hydro,"shocktube_hot")) {
    schedule GRHydro_shocktube_hot in HydroBase_Initial AFTER (HydroBase_Y_e_one,HydroBase_Zero)
    {
      LANG: Fortran
    } "Hot Shocktube initial data"
}

if (CCTK_Equals(initial_hydro,"shocktube")) {
  if(CCTK_Equals(initial_Bvec,"shocktube"))
  {
    schedule GRHydro_shocktubeM in HydroBase_Initial
    {
      LANG: Fortran
    } "Shocktube initial data - MHD version"

    if(CCTK_Equals(shocktube_type,"diagshock")) 
    {
      if(clean_divergence){
        schedule GRHydro_Diagshock_BoundaryM IN ApplyBCs AFTER BoundaryConditions AFTER Boundary::Boundary_ClearSelection
        {
          LANG: Fortran
          SYNC: GRHydro::dens, GRHydro::tau, GRHydro::scon, GRHydro::Bcons, GRHydro::psidc
        } "Diagonal shock boundary conditions"
      } else {
        schedule GRHydro_Diagshock_BoundaryM IN ApplyBCs AFTER BoundaryConditions AFTER Boundary::Boundary_ClearSelection
        {
          LANG: Fortran
          SYNC: GRHydro::dens, GRHydro::tau, GRHydro::scon, GRHydro::Bcons
        } "Diagonal shock boundary conditions"
      }
    }

    if(CCTK_Equals(shocktube_type,"diagshock2d")) 
    {
        schedule GRHydro_Diagshock2D_BoundaryM IN ApplyBCs AFTER BoundaryConditions AFTER Boundary::Boundary_ClearSelection
        {
          LANG: Fortran
        } "2-D Diagonal shock boundary conditions"
    }

#    if(CCTK_Equals(shocktube_type,"diagshock2d")) 
#    {
#      if(clean_divergence){
#        schedule GRHydro_Diagshock2D_BoundaryM IN ApplyBCs AFTER BoundaryConditions AFTER Boundary::Boundary_ClearSelection
#        {
#          LANG: Fortran
#          SYNC: GRHydro::dens, GRHydro::tau, GRHydro::scon, GRHydro::Bcons, GRHydro::psidc
#        } "2-D Diagonal shock boundary conditions"
#      } else {
#        schedule GRHydro_Diagshock2D_BoundaryM IN ApplyBCs AFTER BoundaryConditions AFTER Boundary::Boundary_ClearSelection
#        {
#          LANG: Fortran
#          SYNC: GRHydro::dens, GRHydro::tau, GRHydro::scon, GRHydro::Bcons
#        } "2-D Diagonal shock boundary conditions"
#      }
#    }

  } else {
    schedule GRHydro_shocktube in HydroBase_Initial
    {
      LANG: Fortran
    } "Shocktube initial data"

  }
}

if (CCTK_Equals(initial_hydro,"cylexp")) {
  schedule GRHydro_CylindricalExplosionM in HydroBase_Initial
    {
      LANG: Fortran
    } "Cylindrical Explosion initial data - MHD-only"
}

if (CCTK_Equals(initial_data,"con2primtest")) {
  STORAGE:GRHydro_init_data_reflevel
  schedule GRHydro_Init_Data_RefinementLevel IN HydroBase_Initial BEFORE GRHydro_con2primtest
  {
    LANG: Fortran
  } "Calculate current refinement level"

  schedule GRHydro_con2primtest in HydroBase_Initial
  {
    LANG: Fortran
  } "Testing the conservative to primitive solver"
}

if (CCTK_Equals(initial_data,"con2prim2con_test")) {
  STORAGE:GRHydro_init_data_reflevel
  schedule GRHydro_Init_Data_RefinementLevel IN HydroBase_Initial BEFORE c2p2c_call
  {
    LANG: Fortran
  } "Calculate current refinement level"

  if(CCTK_Equals(Bvec_evolution_method,"GRHydro"))
  {
    schedule c2p2cM in HydroBase_Initial AS c2p2c_call
    {
      LANG: Fortran
    } "Testing conservative to primitive to conservative - MHD version"
  } else {
    schedule c2p2c in HydroBase_Initial AS c2p2c_call
    {
      LANG: Fortran
    } "Testing conservative to primitive to conservative"
  }
}

if (CCTK_Equals(initial_data,"prim2con2prim_test")) {
  STORAGE:GRHydro_init_data_reflevel
  schedule GRHydro_Init_Data_RefinementLevel IN HydroBase_Initial BEFORE p2c2p_call
  {
    LANG: Fortran
  } "Calculate current refinement level"

  if(CCTK_Equals(Bvec_evolution_method,"GRHydro"))
  {
    schedule p2c2pM in HydroBase_Initial AS p2c2p_call
    {
      LANG: Fortran
    } "Testing primitive to conservative to primitive - MHD version"
  } else {
    schedule p2c2p in HydroBase_Initial AS p2c2p_call
    {
      LANG: Fortran
    } "Testing primitive to conservative to primitive"
  }
}

if (CCTK_Equals(initial_data,"prim2con2prim_polytype_test")) {
  STORAGE:GRHydro_init_data_reflevel
  schedule GRHydro_Init_Data_RefinementLevel IN HydroBase_Initial BEFORE p2c2p_call
  {
    LANG: Fortran
  } "Calculate current refinement level"

  if(CCTK_Equals(Bvec_evolution_method,"GRHydro"))
  {
    schedule p2c2pM_polytype in HydroBase_Initial AS p2c2p_call
    {
      LANG: Fortran
    } "Testing primitive to conservative to primitive - MHD polytype version"
  }
}

if (CCTK_Equals(initial_data,"reconstruction_test")) {
  schedule GRHydro_reconstruction_test in HydroBase_Initial
  {
    LANG: Fortran
    STORAGE: GRHydro_prim_bext
    STORAGE: GRHydro_scalars
    OPTIONS: global loop-local
  } "Testing the reconstruction"
}

if (CCTK_Equals(initial_hydro,"only_atmo")) {
  schedule GRHydro_Only_Atmo in HydroBase_Initial
  {
    LANG: Fortran
  } "Only atmosphere as initial data"
}

if (CCTK_Equals(initial_hydro,"read_conformal")) {
  schedule GRHydro_ReadConformalData in HydroBase_Initial
  {
    LANG: Fortran
  } "Set the missing quantities, after reading in from file initial data from conformally-flat codes (Garching)"
}

if (CCTK_Equals(initial_hydro,"simple_wave")) {
  STORAGE: simple_wave_grid_functions
  STORAGE: simple_wave_scalars
  schedule GRHydro_SimpleWave in HydroBase_Initial
  {
    LANG: Fortran
  } "Set initial data from Anile Miller Motta, Phys.Fluids. 26, 1450 (1983)"

  STORAGE: simple_wave_output
  schedule GRHydro_SimpleWave_Analysis AT CCTK_ANALYSIS AFTER GRHydro_Entropy
  {
    LANG: Fortran
  } "Compute some output variables for the Simple Wave"


}

if (CCTK_EQUALS(initial_hydro, "hydro_bondi_solution_iso"))
{
  SCHEDULE GRHydro_Bondi_Iso IN HydroBase_Initial AFTER HydroBase_ExcisionMaskSetup
  {
    LANGUAGE: Fortran
  } "setup GRHydro vars for the hydrodynamic Bondi solution"
}

if (CCTK_EQUALS(initial_hydro, "magnetized_bondi_solution_iso"))
{
  SCHEDULE GRHydro_BondiM_Iso IN HydroBase_Initial AFTER HydroBase_ExcisionMaskSetup
  {
    LANGUAGE: Fortran
  } "setup GRHydro vars for the magnetized Bondi solution"
}

if (CCTK_EQUALS(initial_hydro, "hydro_bondi_solution"))
{
  SCHEDULE GRHydro_Bondi IN HydroBase_Initial AFTER HydroBase_ExcisionMaskSetup
  {
    LANGUAGE: C
  } "setup GRHydro vars for the hydrodynamic Bondi solution"
}

if (CCTK_EQUALS(initial_hydro, "magnetized_bondi_solution"))
{
  SCHEDULE GRHydro_BondiM IN HydroBase_Initial AFTER HydroBase_ExcisionMaskSetup
  {
    LANGUAGE: C
  } "setup GRHydro vars for the magnetized Bondi solution"
}

if(bondi_evolve_only_annulus) {
SCHEDULE GRHydro_BondiM_Range IN HydroBase_Con2Prim BEFORE Con2Prim
{
  LANG: C
} "force analytic solution outside anulus"
}

if(bondi_overwrite_boundary ) {
# this is a terrible HACK. We really should at least schedule ourselves in
# Boundaries and look at cctk_bbox and the symmetry flags
# by now Cactus is convenient CCTK_LOOP macros for this...
SCHEDULE GRHydro_BondiM_Boundary IN HydroBase_Boundaries BEFORE HydroBase_Select_Boundaries
{
  LANG: C
} "force analytic solution in boundaries"
}

if (CCTK_EQUALS(initial_Bvec, "poloidalmagfield") || CCTK_EQUALS(initial_Avec, "poloidalmagfield"))
{
#  SCHEDULE GRHydro_PoloidalMagFieldM AT CCTK_INITIAL AFTER IN HydroBase_Initial AFTER rnsid_init AFTER TOV_Initial_Data after CCCC_StarMapper_InitialData
#  SCHEDULE GRHydro_PoloidalMagFieldM AT CCTK_POSTINITIAL 
  SCHEDULE GRHydro_PoloidalMagFieldM AT CCTK_INITIAL AFTER HydroBase_Initial BEFORE GRHydroTransformPrimToLocalBasis
  {
    LANGUAGE: Fortran
  } "Set up a poloidal magnetic field. It expects the other fluid variables already to be set, as for example in the TOV solution"
#  SCHEDULE group HydroBase_Boundaries IN HydroBase_Initial AFTER GRHydro_PoloidalMagFieldM 
  SCHEDULE group HydroBase_Boundaries IN CCTK_INITIAL AFTER GRHydro_PoloidalMagFieldM BEFORE GRHydroTransformPrimToLocalBasis
  {
  } "Call boundary conditions after magnetic field initial data setup"
}


param: # Parameter definitions for thorn GRHydro_Init_Data
# $Header$

shares:HydroBase

USES CCTK_INT timelevels
USES KEYWORD Bvec_evolution_method
USES KEYWORD Y_e_evolution_method
USES KEYWORD temperature_evolution_method
USES KEYWORD entropy_evolution_method

EXTENDS KEYWORD initial_hydro ""
{
  "shocktube" :: "Shocktube type"
  "shocktube_hot" :: "Shocktube with hot nuclear EOS"
  "only_atmo"  :: "Set only a low atmosphere"
  "read_conformal":: "After reading in initial alp, rho and gxx from h5 files, sets the other quantities"
  "simple_wave" :: "Set initial data from Anile Miller Motta, Phys.Fluids. 26, 1450 (1983)"
  "monopole"    :: "Monopole at the center"
  "cylexp"      :: "Cylindrical Explosion"
  "rotor"       :: "Magnetic Rotor test from DelZanna,Bucciantini, and Londrillo A&A 400, 397-413 (2003)"
  "advectedloop":: "Magnetic advected loop test"
  "alfvenwave"  :: "Circularly polarized Alfven wave"
  "hydro_bondi_solution" :: "Spherical single black hole Bondi solution"
  "hydro_bondi_solution_iso" :: "Spherical single black hole Bondi solution - TEST ISO CASE!!!!!!"
  "magnetized_bondi_solution" :: "Magnetized Spherical single black hole Bondi solution"
  "magnetized_bondi_solution_iso" :: "Magnetized Spherical single black hole Bondi solution - TEST ISO CASE!!!!!!"
}

EXTENDS KEYWORD initial_Bvec
{
  "shocktube"  :: "Shocktube type"
  "cylexp"     :: "Poloidal Magnetic Field"
  "poloidalmagfield" :: "Poloidal Magnetic Field"
  "magnetized Bondi" :: "radial magnetic field appropriate for Bondi test"
}

EXTENDS KEYWORD initial_Avec
{
  "poloidalmagfield" :: "Poloidal Magnetic Field"
}

EXTENDS KEYWORD initial_entropy
{
  "magnetized Bondi" :: "Initial entropy for a radial magnetic field appropriate for Bondi test"
}


shares:ADMBase

EXTENDS KEYWORD initial_data ""
{
#  "shocktube"    :: "Shock tube initial data for GRHydro"
  "con2primtest"  :: "Testing the con -> prim conversion"
  "con2prim2con_test"   :: "Testing the con -> prim -> con conversion"
  "prim2con2prim_test"  :: "Testing the prim -> con -> prim conversion"
  "prim2con2prim_polytype_test"  :: "Testing the prim -> con -> prim conversion - polytype version"
  "reconstruction_test" :: "Testing reconstruction"
}

private:

KEYWORD shocktube_type "Diagonal or parallel shock?"
{
  "diagshock"  :: "Diagonal across all axes"
  "diagshock2d"   :: "Diagonal across x-y axes"
  "xshock"  :: "Parallel to x axis"
  "yshock"  :: "Parallel to y axis"
  "zshock"  :: "Parallel to z axis"
  "sphere"  :: "spherically symmetric shock"
} "xshock"

KEYWORD shock_case "Simple, Sod's problem or other?"
{
  "Simple"  :: "GRAstro_Hydro test case"
  "Sod"     :: "Sod's problem"
  "Blast"   :: "Strong blast wave"
  "Balsaralike1" :: "Hydro version of Balsara Test #1"
  "Balsara0"    :: "Balsara Test #1, but unmagnetized"
  "Balsara1"    :: "Balsara Test #1"
  "Balsara2"    :: "Balsara Test #2"
  "Balsara3"    :: "Balsara Test #3"
  "Balsara4"    :: "Balsara Test #4"
  "Balsara5"    :: "Balsara Test #5"
  "Alfven"      :: "Generical Alfven Test"
  "Komissarov1" :: "Komissarov Test #1"
  "Komissarov2" :: "Komissarov Test #2"
  "Komissarov3" :: "Komissarov Test #3"
  "Komissarov4" :: "Komissarov Test #4"
  "Komissarov5" :: "Komissarov Test #5"
  "Komissarov6" :: "Komissarov Test #6"
  "Komissarov7" :: "Komissarov Test #7"
  "Komissarov8" :: "Komissarov Test #8"
  "Komissarov9" :: "Komissarov Test #9"
} "Sod"

REAL shock_xpos "Position of shock plane: x"
{
  *:*  :: "Anything"
} 0.0

REAL shock_ypos "Position of shock plane: y"
{
  *:*  :: "Anything"
} 0.0

REAL shock_zpos "Position of shock plane: z"
{
  *:*  :: "Anything"
} 0.0

REAL shock_radius "Radius of sperical shock"
{
  0.0:*   :: "Anything positive"
} 1.0

BOOLEAN change_shock_direction "Change the shock direction"
{ 
} "no"

REAL simple_wave_constant_c_0 "The c_0 constant in Anile Miller Motta, Phys.Fluids. 26, 1450 (1983)"
{
  0:1     :: "It is the sound speed where the fluid velocity is zero"
} 0.3

REAL simple_wave_v_max "The v_max constant in Anile Miller Motta, Phys.Fluids. 26, 1450 (1983)"
{
  0:1     :: "It is the maximum velocity in the initial configuration (see p. 1457, bottom of first column)"
} 0.7

# For the "atmosphere"

REAL atmosphere_vel[3] "Velocity of the atmosphere if non-trivial"
{
  *:*     :: "Anything"
} 0.0

BOOLEAN attenuate_atmosphere "Attenuate the velocity in the atmosphere"
{
} "no"

# Initial magnetic field used by different tests

REAL Bx_init "Initial B-field in the x-dir"
{
  *:*     :: "Anything"
} 0.0

REAL By_init "Initial B-field in the y-dir"
{
  *:*     :: "Anything"
} 0.0

REAL Bz_init "Initial B-field in the z-dir"
{
  *:*     :: "Anything"
} 0.0

# Initial primitive values:
REAL rho_init "Initial rest mass density"
{
 (0:*    :: "Anything positive."
} 1.0d-6

REAL velx_init "Initial x velocity" 
{
 *:*    :: "Anything."
} 1.0d-1

REAL vely_init "Initial y velocity" 
{
 *:*    :: "Anything."
} 1.0d-1

REAL velz_init "Initial z velocity" 
{
 *:*    :: "Anything."
} 1.0d-1

REAL eps_init "Initial specific internal energy"
{
 (0:*    :: "Anything positive."
} 1.0d-6

REAL press_init "Initial pressure"
{
 (0:*    :: "Anything positive."
} 6.666666666666667d-7

# Initial conservative values used by c2p tests:

CCTK_BOOLEAN use_c2p_with_entropy_eqn "Use the con2prim routine that uses the entropy equation instead of the energy equation"
{
} no

REAL dens_init "Initial conserved mass density"
{
 (0:*    :: "Anything positive."
} 1.29047362

REAL sx_init "Initial x component of conserved momentum density"
{
 *:*    :: "Anything."
} 0.166666658

REAL sy_init "Initial y component of conserved momentum density"
{
 *:*    :: "Anything."
} 0.166666658

REAL sz_init "Initial z component of conserved momentum density"
{
 *:*    :: "Anything."
} 0.166666658

REAL tau_init "Initial conserved total energy density"
{
 (0:*    :: "Anything positive."
} 0.484123939

# Initial values for 3-metric components. Default to euclidian 3-metric
REAL gxx_init "Initial xx metric componenent"
{
 *:*    :: "Anything, but be carefull to set a positive definite 3-metric!"
} 1.0

REAL gxy_init "Initial xy metric componenent"
{
 *:*    :: "Anything, but be carefull to set a positive definite 3-metric!"
} 0.0

REAL gxz_init "Initial xz metric componenent"
{
 *:*    :: "Anything, but be carefull to set a positive definite 3-metric!"
} 0.0

REAL gyy_init "Initial yy metric componenent"
{
 *:*    :: "Anything, but be carefull to set a positive definite 3-metric!"
} 1.0

REAL gyz_init "Initial yz metric componenent"
{
 *:*    :: "Anything, but be carefull to set a positive definite 3-metric!"
} 0.0

REAL gzz_init "Initial zz metric componenent"
{
 *:*    :: "Anything, but be carefull to set a positive definite 3-metric!"
} 1.0


KEYWORD monopole_type "Which kind of monopole?"
{
  "Point" :: "Single point with Bx /= 0"
  "Gauss" :: "Gaussian w/radius R_Gauss"
  "1dalt" :: "1-d alternating"
  "2dalt" :: "2-d alternating"
  "3dalt" :: "3-d alternating"
} "Point"

CCTK_REAL R_Gauss "Radius for a Gaussian monopole"
{
  0:* :: "Any positive number"
} 1.0

CCTK_REAL Monopole_point_Bx "Pointlike Monopole Bx value"
{
  *:* :: "Any number"
} 1.0

# For cylindrical explosion test:
CCTK_REAL cyl_r_inner "Inner Radius"
{
  (0:* :: "Any positive number"
} 0.8

CCTK_REAL cyl_r_outer "Outer Radius"
{
  (0:* :: "Any positive number"
} 1.0

# the defaults are Komissarov's values
CCTK_REAL cyl_rho_inner "density in inner core"
{
  (0:* :: "any positive number"
} 1.d-2

CCTK_REAL cyl_press_inner "pressure in inner core"
{
  (0:* :: "any positive number"
} 1.d0

CCTK_REAL cyl_rho_outer "density in outer region"
{
  (0:* :: "any positive number"
} 1.d-4

CCTK_REAL cyl_press_outer "pressure in outer region"
{
  (0:* :: "any positive number"
} 3.d-5

# For magnetic advected loop test:

KEYWORD advectedloop_type "2-dimensional or 3-dimensional?"
{
  "2D"  :: "2-dimensional (B^z=0)"
  "3D"  :: "3-dimensional (B^3=0, where B^3 || oblique cylinder axis."
} "2D"

KEYWORD advectedloop_case "V^z=0 or not?"
{
  "V^z=0"  :: "Useful to evaluate divB deviations"
  "V^z/=0" :: "Useful to evaluate con2prim robustness in keeping V^z const."
} "V^z=0"

KEYWORD advectedloop_delA "How to calculate B^i field from the potential A^b"
{
  "Exact"   :: "Analytic, exact closed formula applied"
  "Numeric" :: "Finite difference approximation of the derivatives applied"
} "Exact"

#################################3
# Alfven Wave test
################################3
KEYWORD alfvenwave_type "1-dimensional or 2-dimensional?"
{
  "1D"  :: "1-dimensional"
  "2D"  :: "2-dimensional (in x-y plane)"
} "1D"

CCTK_REAL alfvenwave_pressure "P_gas for the Alfven wave"
{
  (0:* :: "positive"
} 1.0

##################################################################################
# BONDI PARAMETERS: (black hole mass specified by parameters from the "Exact" thorn)
##################################################################################
# Default value is that used in the HARM test
CCTK_REAL mdot_sonicpt_bondi "Accretion rate at sonic point in hydro units"
{
  (0:* :: "positive"
} 12.566370614359172954

CCTK_REAL  r_sonicpt_bondi  "Radial distance of the sonic point from the black hole in units of mass_bh_bondi"
{
  (0:* :: "positive"
} 8.0

keyword bondi_coordinates  "Which coordinate system to use"
{
  "Boyer-Lindquist" :: "Schwarzschild or Boyer-Lindquist (Cartesian) Coordinates"
  "Kerr-Schild"   :: "Kerr-Schild (Cartesian) Coordinates"
  "Isotropic"     :: "Isotropic (Cartesian) Coordinates"
} "Isotropic" 


CCTK_INT num_bondi_sols  "Number of central masses about which to calculate Bondi solutions"
{
  1:100 :: "positive"
} 1

CCTK_REAL bh_bondi_pos_x [100] "X-coordinate of black hole in Bondi solution"
{
  *:* :: "anything"
} 0.0

CCTK_REAL bh_bondi_pos_y [100] "Y-coordinate of black hole in Bondi solution"
{
  *:* :: "anything"
} 0.0

CCTK_REAL bh_bondi_pos_z [100] "Z-coordinate of black hole in Bondi solution"
{
  *:* :: "anything"
} 0.0

CCTK_REAL bondi_central_mass [100] "Mass of central object to find Bondi solution about  "
{
  (0:* :: "positive"
} 1.0

CCTK_REAL bondi_central_spin [100] "Dimensionless spin of central object within Bondi solution "
{
  (-1.:1.) :: "dimensionless spin so any real number between -1 and 1"
} 0.0

CCTK_REAL bondi_rmin [100] "Smallest radius in units of central mass at which the solution is found"
{
  (0:*  :: "dimensionless inner radius for Bondi solution"
} 1.e-15

CCTK_REAL bondi_rmax [100] "Largest radius in units of central mass at which the solution is found"
{
  (0:*  :: "dimensionless outer radius for Bondi solution"
} 400. 

CCTK_REAL n_bondi_pts [100] "Number of points to use in determining global Bondi solution"
{
  (1:*  :: "number of points in global Bondi solution"
} 2000

CCTK_REAL bondi_bmag "B_0 parameter for magnetized Bondi"
{
  0:* :: "Anything positive"
} 0.01

CCTK_REAL bondi_radial_offset "redefine r_grid=r_KS-r0 to avoid singularity on grid"
{
  0:* :: "Any positive number"
} 0.0

CCTK_BOOLEAN set_bondi_beta_sonicpt "Set plasma beta parameter instead of bondi_bmag"
{
} no

CCTK_REAL  bondi_beta_sonicpt "Plasma beta parameter at the sonic point. Calculate bondi_bmag afterwards."
{
  (0:* :: "positive"
} 1.0

CCTK_KEYWORD bondi_Bvec_method "how to compute the magnetic field vector"
{
  "direct"    :: "directly from Cartesian metric"
  "transform" :: "transform Schwarzschild solution to Kerr Schild"
} "direct"

CCTK_BOOLEAN bondi_evolve_only_annulus "reset to initial data outside of bondi_freeze_inner_radius and bondi_freeze_outer_radius"
{
} "no"

CCTK_REAL bondi_freeze_inner_radius "reset to initial at radii below this"
{
  *:* :: "any value"
} -1.

CCTK_REAL bondi_freeze_outer_radius "reset to initial at radii above this"
{
  *:* :: "any value"
} 1e300

CCTK_BOOLEAN bondi_overwrite_boundary "reset data to initial data in outer boundary in boundary condition"
{
} "no"

# For Poloidal Magnetic field test:

CCTK_REAL poloidal_A_b  "Vector potential strength"
{
  *:* :: "Anything."
} 0.1

CCTK_INT poloidal_n_p  "Vector potential strength"
{
  0:*  :: "Any positive integer."
} 3

CCTK_REAL poloidal_P_cut  "Pressure used to confine the B field inside a star"
{
  (0:*  :: "Anything positive."
} 1.0e-8

CCTK_INT poloidal_P_p "Index of pressure factor"
{
 (0:* :: "Any non-negative integer"
} 1

CCTK_REAL poloidal_rho_max  "Maximum initial density"
{
  (0:*  :: "Anything positive."
} 1.0e-3

# for the Magnetic Rotor test:
# default values are from DelZanna,Bucciantini, and Londrillo A&A 400, 397–413 (2003) though notation differs

CCTK_REAL rotor_xc "center of rotation"
{
  *:* :: "Any location"
} 0.5

CCTK_REAL rotor_yc "center of rotation"
{
  *:* :: "Any location"
} 0.5

CCTK_REAL rotor_bvcxl "intial component of Bvec[0]"
{
  *:* :: "any real number"
} 1.0

CCTK_REAL rotor_bvcyl "intial component of Bvec[1]"
{
  *:* :: "any real number"
} 0.0

CCTK_REAL rotor_bvczl "intial component of Bvec[2]"
{
  *:* :: "any real number"
} 0.0
  
CCTK_REAL rotor_r_rot "radius of rotor"
{
  (0:* :: "any positive number"
} 0.1
  
CCTK_REAL rotor_v_max "Maximum velocity"
{
  (-1:1) :: "any subluminal speed (negative is clockwise)"
} 0.995


CCTK_REAL rotor_rhoin "initial density inside rotor"
{
  (0:* :: "any positive number"
} 10.d0

CCTK_REAL rotor_pressin "initial pressure inside rotor"
{
  (0:* :: "any positive number"
} 1.d0

CCTK_REAL rotor_rhoout "initial density outside rotor"
{
  (0:* :: "any positive number"
} 1.d0

CCTK_REAL rotor_pressout "initial pressure outside rotor"
{
  (0:* :: "any positive number"
} 1.d0

CCTK_BOOLEAN rotor_use_smoothing "Smooth the edge?"
{
} yes

CCTK_REAL rotor_rsmooth_rel "Define the radius in relative terms if so"
{
  (0:* :: "any positive number"
} 0.05


shares:GRHydro

USES real GRHydro_eos_rf_prec
USES real GRHydro_rho_central
USES real GRHydro_eps_min ""
USES real GRHydro_perc_ptol ""
USES real GRHydro_del_ptol ""
USES string GRHydro_eos_type ""
USES string GRHydro_eos_table ""
USES real rho_abs_min
USES real rho_rel_min
USES REAL initial_rho_abs_min
USES REAL initial_rho_rel_min
USES REAL initial_atmosphere_factor
USES int GRHydro_stencil
USES BOOLEAN clean_divergence

shares:EOS_Omni
USES REAL gl_gamma
USES BOOLEAN nuceos_read_table

configuration: REQUIRES EOS_Omni Fortran

context: make.configuration.defn:
```
# Main make.code.defn file for thorn Hydra_Init_Data
# $Header$



```

GRHydro_ShockTubeM.F90:
```
 /*@@
   @file      GRHydro_ShockTubeM.F90
   @date      Sep 23, 2010
   @author    Joshua Faber, Scott Noble, Bruno Mundim, Ian Hawke
   @desc 
   Initial data of the shock tube type - MHD version.
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)
#define Bvecx(i,j,k) Bvec(i,j,k,1)
#define Bvecy(i,j,k) Bvec(i,j,k,2)
#define Bvecz(i,j,k) Bvec(i,j,k,3)
#define Bconsx(i,j,k) Bcons(i,j,k,1)
#define Bconsy(i,j,k) Bcons(i,j,k,2)
#define Bconsz(i,j,k) Bcons(i,j,k,3)

#define OOSQRT2 (0.7071067811865475244008442)
#define OOSQRT3 (0.5773502691896257645091489)
#define OOSQRT6 (0.4082482904638630163662140)


 /*@@
   @routine    GRHydro_shocktubeM
   @date       Sat Jan 26 02:53:49 2002
   @author     Joshua Faber, Scott Noble, Bruno Mundim, Ian Hawke
   @desc 
   Initial data for shock tubes, parallel to
   a coordinate axis. Either Sods problem or the standard shock tube.
   @enddesc 
   @calls     
   @calledby   
   @history 
   Expansion and alteration of the test code from GRAstro_Hydro, 
   written by Mark Miller.
   @endhistory 

@@*/

subroutine GRHydro_shocktubeM(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz
  CCTK_REAL :: direction, det, DIRECTION_TINY
  CCTK_REAL :: rhol, rhor, velxl, velxr, velyl, velyr, &
       velzl, velzr, epsl, epsr
  CCTK_REAL :: bvcxl,bvcyl,bvczl,bvcxr,bvcyr,bvczr
  CCTK_REAL :: ux,uy,uz,ut,tmp,tmp2,tmp3
  
  
  bvcxl = Bx_init
  bvcyl = By_init
  bvczl = Bz_init
  bvcxr = Bx_init
  bvcyr = By_init
  bvczr = Bz_init

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)
  
  do i=1,nx
    do j=1,ny
      do k=1,nz
        if (CCTK_EQUALS(shocktube_type,"diagshock")) then
!!$ The diagshock choice yields a shock plane perpendicular to the fixed vector (1,1,1)
!!$ This could be changed, but would require 3 new params containing the new shock direction
           direction = x(i,j,k) - shock_xpos + &
                y(i,j,k) - shock_ypos + z(i,j,k) - shock_zpos

        else if (CCTK_EQUALS(shocktube_type,"diagshock2d")) then
!!$ The diagshock choice yields a shock plane perpendicular to the fixed vector (1,1,0), with similarity in the z-dir.
!!$ This could be changed, but would require 2 new params containing the new shock direction
           direction = x(i,j,k) - shock_xpos + &
                y(i,j,k) - shock_ypos

        else if (CCTK_EQUALS(shocktube_type,"xshock")) then
           direction = x(i,j,k) - shock_xpos
        else if (CCTK_EQUALS(shocktube_type,"yshock")) then
           direction = y(i,j,k) - shock_ypos
        else if (CCTK_EQUALS(shocktube_type,"zshock")) then
           direction = z(i,j,k) - shock_zpos
        else if (CCTK_EQUALS(shocktube_type,"sphere")) then
           direction = sqrt((x(i,j,k)-shock_xpos)**2+&
                (y(i,j,k)-shock_ypos)**2+&
                (z(i,j,k)-shock_zpos)**2)-shock_radius
        end if
        if (CCTK_EQUALS(shock_case,"Simple")) then
          rhol = 10.d0
          rhor = 1.d0
          velxl = 0.d0
          velxr = 0.d0
          velyl = 0.d0
          velyr = 0.d0
          velzl = 0.d0
          velzr = 0.d0
          epsl = 2.d0
          epsr = 1.d-6
        else if (CCTK_EQUALS(shock_case,"Sod")) then
          rhol = 1.d0
          rhor = 0.125d0
          velxl = 0.d0
          velxr = 0.d0
          velyl = 0.d0
          velyr = 0.d0
          velzl = 0.d0
          velzr = 0.d0
          epsl = 1.5d0
          epsr = 1.2d0
!!$This line only for polytrope, k=1
!!$          epsr = 0.375d0
        else if (CCTK_EQUALS(shock_case,"Blast")) then
          rhol = 1.d0
          rhor = 1.d0
          velxl = 0.d0
          velxr = 0.d0
          velyl = 0.d0
          velyr = 0.d0
          velzl = 0.d0
          velzr = 0.d0
          epsl = 1500.d0
          epsr = 1.5d-2

!!$ The following shocktubes are from Balsara, ApJSS 132 p83 (2001),
!!$ http://adsabs.harvard.edu/abs/2001ApJS..132...83B.
!!$   All use n=1600 cells, over domain x=[-0.5,0.5]
!!$   All assume ideal-gas or gamma-law EOS, the first test uses GAMMA=2. while the rest GAMMA=5./3.

!!$ Unmagnetized Test 1 (rel. Brio & Wu 1988 by van Putten 1993) of Balsara 2001 -- compare at t=0.4
       else if (CCTK_EQUALS(shock_case,"Balsara0")) then
          rhol = 1.0d0
          rhor = 0.125d0
          velxl = 0.0d0
          velxr = 0.0d0
          velyl = 0.0d0
          velyr = 0.0d0
          velzl = 0.0d0
          velzr = 0.0d0
          bvcxl=0.0d0
          bvcxr=0.0d0
          bvcyl=0.0d0
          bvcyr=0.0d0
          bvczl=0.0d0
          bvczr=0.0d0
          epsl = 1.0d0/rhol
          epsr = 0.1d0/rhor

!!$ Test 1 (rel. Brio & Wu 1988 by van Putten 1993) of Balsara 2001 -- compare at t=0.4
       else if (CCTK_EQUALS(shock_case,"Balsara1")) then
          rhol = 1.0d0
          rhor = 0.125d0
          velxl = 0.0d0
          velxr = 0.0d0
          velyl = 0.0d0
          velyr = 0.0d0
          velzl = 0.0d0
          velzr = 0.0d0
          bvcxl=0.5d0
          bvcxr=0.5d0
          bvcyl=1.0d0
          bvcyr=-1.0d0
          bvczl=0.0d0
          bvczr=0.0d0
          epsl = 1.0d0/rhol
          epsr = 0.1d0/rhor

!!$ Test 2 (blast wave) of Balsara 2001  -- compare at t=0.4
       else if (CCTK_EQUALS(shock_case,"Balsara2")) then
          rhol = 1.d0
          rhor = 1.d0
          velxl = 0.d0
          velxr = 0.d0
          velyl = 0.d0
          velyr = 0.d0
          velzl = 0.d0
          velzr = 0.d0
          bvcxl=5.0d0
          bvcxr=5.0d0
          bvcyl=6.d0
          bvcyr=0.7d0
          bvczl=6.d0
          bvczr=0.7d0
          epsl = 1.5d0*30.0d0/rhol
          epsr = 1.5d0*1.0d0/rhor

!!$ Test 3 (blast wave) of Balsara 2001  -- compare at t=0.4
       else if (CCTK_EQUALS(shock_case,"Balsara3")) then
          rhol = 1.d0
          rhor = 1.d0
          velxl = 0.d0
          velxr = 0.d0
          velyl = 0.d0
          velyr = 0.d0
          velzl = 0.d0
          velzr = 0.d0
          bvcxl=10.0d0
          bvcxr=10.0d0
          bvcyl=7.d0
          bvcyr=0.7d0
          bvczl=7.d0
          bvczr=0.7d0
          epsl = 1.5d0*1000.0d0/rhol
          epsr = 1.5d0*0.1d0/rhor

!!$ Test 4 (rel. version of Noh 1987) of Balsara 2001  -- compare at t=0.4
       else if (CCTK_EQUALS(shock_case,"Balsara4")) then
          rhol = 1.d0
          rhor = 1.d0
          velxl = 0.999d0
          velxr = -0.999d0
          velyl = 0.d0
          velyr = 0.d0
          velzl = 0.d0
          velzr = 0.d0
          bvcxl=10.0d0
          bvcxr=10.0d0
          bvcyl=7.d0
          bvcyr=-7.d0
          bvczl=7.d0
          bvczr=-7.d0
          epsl = 1.5d0*0.1d0/rhol
          epsr = 1.5d0*0.1d0/rhor

!!$ Test 5 (non-coplanar set of waves) of Balsara 2001  -- compare at t=0.55
       else if (CCTK_EQUALS(shock_case,"Balsara5")) then
          rhol = 1.08d0
          rhor = 1.d0
          velxl = 0.4d0
          velxr = -0.45d0
          velyl = 0.3d0
          velyr = -0.2d0
          velzl = 0.2d0
          velzr = 0.2d0
          bvcxl=2.0d0
          bvcxr=2.0d0
          bvcyl=0.3d0
          bvcyr=-0.7d0
          bvczl=0.3d0
          bvczr=0.5d0
          epsl = 1.5d0*0.95d0/rhol
          epsr = 1.5d0*1.0d0/rhor

!!$  "Generic Alfven Test of  Giacomazzo and Rezzolla J.Comp.Phys (2006)
       else if (CCTK_EQUALS(shock_case,"Alfven")) then
          rhol = 1.d0
          rhor = 0.9d0
          velxl = 0.d0
          velxr = 0.d0
          velyl = 0.3d0
          velyr = 0.d0
          velzl = 0.4d0
          velzr = 0.d0
          bvcxl=1.0d0
          bvcxr=1.0d0
          bvcyl=6.d0
          bvcyr=5.d0
          bvczl=2.d0
          bvczr=2.d0
          epsl = 1.5d0*5.d0/rhol
          epsr = 1.5d0*5.3d0/rhor

!!$ The following 9 tests are from Komissarov MNRAS 303 p343 (1999),
!!$ http://adsabs.harvard.edu/abs/1999MNRAS.303..343K. 
!!$   Note that the data is specified in terms of the 4-velocity, so some conversion is necessary. 
!!$   All assume ideal-gas or gamma-law EOS with GAMMA=4./3. 

!!$ Fast Shock test of Komissarov 1999 -- compare  at t=2.5 , n=40, x=[-1,1]
       else if (CCTK_EQUALS(shock_case,"Komissarov1")) then
          rhol = 1.d0
          rhor = 25.48d0
          bvcxl=20.d0
          bvcxr=20.d0
          bvcyl=25.02d0
          bvcyr=49.d0
          bvczl=0.d0
          bvczr=0.d0
          epsl = 3.d0 * 1.d0  /rhol
          epsr = 3.d0 * 367.5d0 /rhor

          ux=25.d0
          uy=0.d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxl = ux/ut
          velyl = uy/ut
          velzl = uz/ut

          ux=1.091d0
          uy=0.3923d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxr = ux/ut
          velyr = uy/ut
          velzr = uz/ut

!!$ Slow Shock test of Komissarov 1999 -- compare at t=2. , n=200,  x=[-0.5,1.5]
       else if (CCTK_EQUALS(shock_case,"Komissarov2")) then
          rhol = 1.d0
          rhor = 3.323d0
          bvcxl=10.d0
          bvcxr=10.d0
          bvcyl=18.28d0
          bvcyr=14.49d0
          bvczl=0.d0
          bvczr=0.d0
          epsl = 3.d0 * 1.d0  /rhol
          epsr = 3.d0 * 55.36d0 /rhor

          ux=1.53d0
          uy=0.d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxl = ux/ut
          velyl = uy/ut
          velzl = uz/ut

          ux=0.9571d0
          uy=-0.6822d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxr = ux/ut
          velyr = uy/ut
          velzr = uz/ut

!!$ Switch-off Fast test of Komissarov 1999 -- compare  at t=1. , n=150, x=[-1,1] 
       else if (CCTK_EQUALS(shock_case,"Komissarov3")) then
          rhol = 0.1d0
          rhor = 0.562d0
          bvcxl=2.d0
          bvcxr=2.d0
          bvcyl=0.d0
          bvcyr=4.710d0
          bvczl=0.d0
          bvczr=0.d0
          epsl = 3.d0 * 1.d0  /rhol
          epsr = 3.d0 * 10.d0 /rhor

          ux=-2.d0
          uy=0.d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxl = ux/ut
          velyl = uy/ut
          velzl = uz/ut

          ux=-0.212d0
          uy=-0.590d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxr = ux/ut
          velyr = uy/ut
          velzr = uz/ut

!!$ Switch-on Slow test of Komissarov 1999 -- compare  at t=2. , n=150, x=[-1,1.5]
       else if (CCTK_EQUALS(shock_case,"Komissarov4")) then
          rhol = 1.78d-2
          rhor = 1.d-2
          bvcxl=1.d0
          bvcxr=1.d0
          bvcyl=1.022d0
          bvcyr=0.d0
          bvczl=0.d0
          bvczr=0.d0
          epsl = 3.d0 * 0.1d0  /rhol
          epsr = 3.d0 * 1.d0 /rhor

          ux=-0.765d0
          uy=-1.386d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxl = ux/ut
          velyl = uy/ut
          velzl = uz/ut

          ux=0.d0
          uy=0.d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxr = ux/ut
          velyr = uy/ut
          velzr = uz/ut

!!$ Alfven wave test of Komissarov 1999 -- compare  at t=2. , n=200, x=[-1,1.5]
!!$   Needs special setup -- FIX
       else if (CCTK_EQUALS(shock_case,"Komissarov5")) then
          rhol = 1.d0
          rhor = 1.d0
          bvcxl=3.d0
          bvcxr=3.d0
          bvcyl=3.d0
          bvcyr=-6.857d0
          bvczl=0.d0
          bvczr=0.d0
          epsl = 3.d0 * 1.d0  /rhol
          epsr = 3.d0 * 1.d0 /rhor

          ux=0.d0
          uy=0.d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxl = ux/ut
          velyl = uy/ut
          velzl = uz/ut

          ux=3.70d0
          uy=5.76d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxr = ux/ut
          velyr = uy/ut
          velzr = uz/ut

!!$ Compound wave test of Komissarov 1999 -- compare  at t=0.1,0.75,1.5 , n=200, x=[-0.5,1.5]
!!$   Needs special setup -- FIX
       else if (CCTK_EQUALS(shock_case,"Komissarov6")) then
          rhol = 1.d0
          rhor = 1.d0
          bvcxl=3.d0
          bvcxr=3.d0
          bvcyl=3.d0
          bvcyr=-6.857d0
          bvczl=0.d0
          bvczr=0.d0
          epsl = 3.d0 * 1.d0  /rhol
          epsr = 3.d0 * 1.d0 /rhor

          ux=0.d0
          uy=0.d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxl = ux/ut
          velyl = uy/ut
          velzl = uz/ut

          ux=3.70d0
          uy=5.76d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxr = ux/ut
          velyr = uy/ut
          velzr = uz/ut

!!$ Shock Tube 1  test of Komissarov 1999 -- compare  at t=1. , n=400, x=[-1,1.5]
       else if (CCTK_EQUALS(shock_case,"Komissarov7")) then
          rhol = 1.d0
          rhor = 1.d0
          bvcxl=1.d0
          bvcxr=1.d0
          bvcyl=0.d0
          bvcyr=0.d0
          bvczl=0.d0
          bvczr=0.d0
          epsl = 3.d0 * 1.d3  /rhol
          epsr = 3.d0 * 1.d0 /rhor

          velxl = 0.
          velyl = 0.
          velzl = 0.

          velxr = 0.
          velyr = 0.
          velzr = 0.

!!$ Shock Tube 2 test of Komissarov 1999 -- compare  at t=1. , n=500, x=[-1.25,1.25]
       else if (CCTK_EQUALS(shock_case,"Komissarov8")) then
          rhol = 1.d0
          rhor = 1.d0
          bvcxl=0.d0
          bvcxr=0.d0
          bvcyl=20.d0
          bvcyr=0.d0
          bvczl=0.d0
          bvczr=0.d0
          epsl = 3.d0 * 30.d0  /rhol
          epsr = 3.d0 * 1.d0 /rhor

          velxl = 0.
          velyl = 0.
          velzl = 0.

          velxr = 0.
          velyr = 0.
          velzr = 0.

!!$ Collision test of Komissarov 1999 -- compare  at t=1.22 , n=200, x=[-1,1]
       else if (CCTK_EQUALS(shock_case,"Komissarov9")) then
          rhol = 1.d0
          rhor = 1.d0
          bvcxl=10.d0
          bvcxr=10.d0
          bvcyl=10.d0
          bvcyr=-10.d0
          bvczl=0.d0
          bvczr=0.d0
          epsl = 3.d0 * 1.d0  /rhol
          epsr = 3.d0 * 1.d0 /rhor

          ux=5.d0
          uy=0.d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxl = ux/ut
          velyl = uy/ut
          velzl = uz/ut

          ux=-5.d0
          uy=0.d0
          uz=0.d0
          ut = sqrt(1. + ux*ux + uy*uy + uz*uz)
          velxr = ux/ut
          velyr = uy/ut
          velzr = uz/ut

       else
          call CCTK_WARN(0,"Shock case not recognized")
        end if

        DIRECTION_TINY = 0.0001*CCTK_DELTA_SPACE(1)

        if ( ((change_shock_direction==0).and.(direction .lt. DIRECTION_TINY)).or.& 
             ((change_shock_direction==1).and.(direction .gt. DIRECTION_TINY)) ) then

!!$ Left state

          rho(i,j,k) = rhol
          velx(i,j,k) = velxl
          vely(i,j,k) = velyl
          velz(i,j,k) = velzl
          eps(i,j,k) = epsl
          Bvecx(i,j,k)=bvcxl
          Bvecy(i,j,k)=bvcyl
          Bvecz(i,j,k)=bvczl
        else

!!$ Right state

          rho(i,j,k) = rhor
          velx(i,j,k) = velxr
          vely(i,j,k) = velyr
          velz(i,j,k) = velzr
          eps(i,j,k) = epsr
          Bvecx(i,j,k)=bvcxr
          Bvecy(i,j,k)=bvcyr
          Bvecz(i,j,k)=bvczr
        end if

        
        if (CCTK_EQUALS(shocktube_type,"yshock")) then
!!$ Cycle x,y,z forward           
           tmp=velx(i,j,k)
           velx(i,j,k)=velz(i,j,k)
           velz(i,j,k)=vely(i,j,k)
           vely(i,j,k)=tmp
           tmp=Bvecx(i,j,k)
           Bvecx(i,j,k)=Bvecz(i,j,k)
           Bvecz(i,j,k)=Bvecy(i,j,k)
           Bvecy(i,j,k)=tmp
        else if (CCTK_EQUALS(shocktube_type,"zshock")) then
!!$ Cycle x,y,z backward           
           tmp=velx(i,j,k)
           velx(i,j,k)=vely(i,j,k)
           vely(i,j,k)=velz(i,j,k)
           velz(i,j,k)=tmp
           tmp=Bvecx(i,j,k)
           Bvecx(i,j,k)=Bvecy(i,j,k)
           Bvecy(i,j,k)=Bvecz(i,j,k)
           Bvecz(i,j,k)=tmp
        else if (CCTK_EQUALS(shocktube_type,"diagshock")) then
!!$ Rotated basis vectors necessary to evaluate the orthogonal matrix elements:
!!$ xhat = 1/sqrt(3)[1,1,1], yhat = 1/sqrt(2)[-1,1,0]; zhat = 1/sqrt(6)[-1,-1,2]
!!$ Orthogonal matrix constructed from the tensor product between the original
!!$ cartesian basis x's and new basis vectors xhat's, rotated towards the diagonal 
!!$ shock normal and tangent directions.
           tmp  = OOSQRT3*velx(i,j,k) - OOSQRT2*vely(i,j,k) - OOSQRT6*velz(i,j,k)
           tmp2 = OOSQRT3*velx(i,j,k) + OOSQRT2*vely(i,j,k) - OOSQRT6*velz(i,j,k)
           tmp3 = OOSQRT3*velx(i,j,k)                  + 2.d0*OOSQRT6*velz(i,j,k)
           velx(i,j,k)=tmp
           vely(i,j,k)=tmp2
           velz(i,j,k)=tmp3
           tmp  = OOSQRT3*Bvecx(i,j,k) - OOSQRT2*Bvecy(i,j,k) - OOSQRT6*Bvecz(i,j,k)
           tmp2 = OOSQRT3*Bvecx(i,j,k) + OOSQRT2*Bvecy(i,j,k) - OOSQRT6*Bvecz(i,j,k)
           tmp3 = OOSQRT3*Bvecx(i,j,k)                   + 2.d0*OOSQRT6*Bvecz(i,j,k)
           Bvecx(i,j,k)=tmp
           Bvecy(i,j,k)=tmp2
           Bvecz(i,j,k)=tmp3
        else if (CCTK_EQUALS(shocktube_type,"diagshock2d")) then
!!$ New basis:
!!$ xhat = 1/sqrt(2)[1,1,0], yhat = 1/sqrt(2)[-1,1,0]; zhat = [0,0,1]
           tmp  = OOSQRT2*velx(i,j,k) - OOSQRT2*vely(i,j,k)
           tmp2 = OOSQRT2*velx(i,j,k) + OOSQRT2*vely(i,j,k)
           velx(i,j,k)=tmp
           vely(i,j,k)=tmp2
           tmp  = OOSQRT2*Bvecx(i,j,k) - OOSQRT2*Bvecy(i,j,k)
           tmp2 = OOSQRT2*Bvecx(i,j,k) + OOSQRT2*Bvecy(i,j,k)
           Bvecx(i,j,k)=tmp
           Bvecy(i,j,k)=tmp2
        endif
           
        det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))

        if (CCTK_EQUALS(GRHydro_eos_type,"Polytype")) then
          call Prim2ConPolyM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
               gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
               det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
               tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k),&
               eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
               w_lorentz(i,j,k))
        else
          call Prim2ConGenM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
               gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
               det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
               tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k),&
               eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
               w_lorentz(i,j,k))
        end if
    enddo
    enddo
  enddo

  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0
  Bconsrhs = 0.d0


  return
  
end subroutine GRHydro_shocktubeM

subroutine GRHydro_Diagshock_BoundaryM(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz, sten, stenp1, minsum, maxsum
  CCTK_INT :: inew, jnew, knew
  CCTK_INT :: xoff,yoff,zoff,indsum
  CCTK_REAL :: det
  CCTK_INT :: status
  character(len=200) :: error_message
  integer :: gindex_tau, gindex_dens, gindex_scon, gindex_Bcons
  CCTK_INT, parameter :: num_groups = 4
  CCTK_INT :: groups(num_groups)


  sten=GRHydro_stencil
  stenp1=GRHydro_stencil + 1

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)
  
  minsum = 3*stenp1
  maxsum = nx+ny+nz-3*stenp1 + 3

  xoff=0
  yoff=0
  zoff=0
        
!!$ Loop over the cubical domain 6 faces:

  !!$ 1) xmin:
  do k = stenp1, nz-sten
    do j = stenp1, ny-sten
      do i = 1, sten

        indsum = i+j+k
        if(indsum.lt.minsum) then
          inew = stenp1
          jnew = stenp1
          knew = stenp1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else if(indsum.gt.maxsum) then
          inew = nx - stenp1 + 1
          jnew = ny - stenp1 + 1
          knew = nz - stenp1 + 1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else
           call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
          dens(i,j,k) = dens(inew,jnew,knew)
        end if
           
        sx(i,j,k) = sx(inew,jnew,knew)
        sy(i,j,k) = sy(inew,jnew,knew)
        sz(i,j,k) = sz(inew,jnew,knew)
        tau(i,j,k) = tau(inew,jnew,knew)
        Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
        Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
        Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,knew)
        endif

      end do 
    end do
  end do 

  !!$ 2) xmax:
  do k = stenp1, nz-sten
    do j = stenp1, ny-sten
      do i = nx-sten+1, nx

        indsum = i+j+k
        if(indsum.lt.minsum) then
          inew = stenp1
          jnew = stenp1
          knew = stenp1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else if(indsum.gt.maxsum) then
          inew = nx - stenp1 + 1
          jnew = ny - stenp1 + 1
          knew = nz - stenp1 + 1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else
           call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
           dens(i,j,k) = dens(inew,jnew,knew)
        end if
           
        sx(i,j,k) = sx(inew,jnew,knew)
        sy(i,j,k) = sy(inew,jnew,knew)
        sz(i,j,k) = sz(inew,jnew,knew)
        tau(i,j,k) = tau(inew,jnew,knew)
        Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
        Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
        Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,knew)
        endif

      end do 
    end do
  end do 

  !!$ 3) ymin:
  do k = stenp1, nz-sten
    do j = 1, sten
      do i =  stenp1, nx-sten

        indsum = i+j+k
        if(indsum.lt.minsum) then
          inew = stenp1
          jnew = stenp1
          knew = stenp1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else if(indsum.gt.maxsum) then
          inew = nx - stenp1 + 1
          jnew = ny - stenp1 + 1
          knew = nz - stenp1 + 1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else
           call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
           dens(i,j,k) = dens(inew,jnew,knew)
        end if
           
        sx(i,j,k) = sx(inew,jnew,knew)
        sy(i,j,k) = sy(inew,jnew,knew)
        sz(i,j,k) = sz(inew,jnew,knew)
        tau(i,j,k) = tau(inew,jnew,knew)
        Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
        Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
        Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,knew)
        endif

      end do 
    end do
  end do 

  !!$ 4) ymax:
  do k = stenp1, nz-sten
    do j = ny-sten+1, ny
      do i = stenp1, nx-sten

        indsum = i+j+k
        if(indsum.lt.minsum) then
          inew = stenp1
          jnew = stenp1
          knew = stenp1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else if(indsum.gt.maxsum) then
          inew = nx - stenp1 + 1
          jnew = ny - stenp1 + 1
          knew = nz - stenp1 + 1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else
           call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
           dens(i,j,k) = dens(inew,jnew,knew)
        end if
           
        sx(i,j,k) = sx(inew,jnew,knew)
        sy(i,j,k) = sy(inew,jnew,knew)
        sz(i,j,k) = sz(inew,jnew,knew)
        tau(i,j,k) = tau(inew,jnew,knew)
        Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
        Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
        Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,knew)
        endif

      end do 
    end do
  end do 

!!$  the following two cases are different for a 3d diagonal than a 2d diagonal

  !!$ 5) zmin:
  do k = 1, sten 
    do j = stenp1, ny-sten
      do i =  stenp1, nx-sten
 
        indsum = i+j+k
        if(indsum.lt.minsum) then
          inew = stenp1
          jnew = stenp1
          knew = stenp1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else if(indsum.gt.maxsum) then
          inew = nx - stenp1 + 1
          jnew = ny - stenp1 + 1
          knew = nz - stenp1 + 1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else
           call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
           dens(i,j,k) = dens(inew,jnew,knew)
        end if
           
        sx(i,j,k) = sx(inew,jnew,knew)
        sy(i,j,k) = sy(inew,jnew,knew)
        sz(i,j,k) = sz(inew,jnew,knew)
        tau(i,j,k) = tau(inew,jnew,knew)
        Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
        Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
        Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,knew)
        endif

      end do 
    end do
  end do 

  !!$ 6) zmax:
  do k = nz-sten+1, nz
    do j = stenp1, ny-sten
      do i = stenp1, nx-sten
 
        indsum = i+j+k
        if(indsum.lt.minsum) then
          inew = stenp1
          jnew = stenp1
          knew = stenp1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else if(indsum.gt.maxsum) then
          inew = nx - stenp1 + 1
          jnew = ny - stenp1 + 1
          knew = nz - stenp1 + 1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else
           call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
           dens(i,j,k) = dens(inew,jnew,knew)
        end if
           
        sx(i,j,k) = sx(inew,jnew,knew)
        sy(i,j,k) = sy(inew,jnew,knew)
        sz(i,j,k) = sz(inew,jnew,knew)
        tau(i,j,k) = tau(inew,jnew,knew)
        Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
        Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
        Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,knew)
        endif

      end do 
    end do
  end do 

!!$ Loop over the cubical domain 12 edges:

  !!$ 1) xmin,ymin:
  do k = stenp1, nz-sten
    do j = 1, sten
      do i = 1, sten

         indsum = i+j+k
!!$ indsum > maxsum impossible!
         if(indsum.lt.minsum) then
            inew = stenp1
            jnew = stenp1
            knew = stenp1
         else
            call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         end if

!!$  Don't poison edges!
         dens(i,j,k) = dens(inew,jnew,knew)
         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 2) xmin,ymax:
  do k = stenp1, nz-sten
    do j =  ny-sten+1, ny
      do i = 1, sten

         indsum = i+j+k
!!$ indsum > maxsum and indsum < minsum both impossible!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)
         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 3) xmax,ymin:
  do k = stenp1, nz-sten
    do j = 1, sten
      do i = nx-sten+1, nx 

         indsum = i+j+k
!!$ indsum > maxsum and indsum < minsum both impossible!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)
         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 4) xmax,ymax:
  do k = stenp1, nz-sten
    do j = ny-sten+1, ny 
      do i = nx-sten+1, nx 

         indsum = i+j+k
!!$ indsum < minsum impossible!
         if(indsum.gt.maxsum) then
            inew = nx - stenp1 + 1
            jnew = ny - stenp1 + 1
            knew = nz - stenp1 + 1
         else
            call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         end if
         
!!$  Don't poison edges!
         dens(i,j,k) = dens(inew,jnew,knew)

         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 5) ymin,zmin:
  do k = 1, sten 
    do j = 1, sten 
      do i =  stenp1, nx-sten

         indsum = i+j+k
!!$ indsum > maxsum impossible!
         if(indsum.lt.minsum) then
            inew = stenp1
            jnew = stenp1
            knew = stenp1
         else
            call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         end if
         
!!$  Don't poison edges!
         dens(i,j,k) = dens(inew,jnew,knew)

         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif
 
      end do 
    end do
  end do 

  !!$ 6) ymin,zmax:
  do k = nz-sten+1, nz
    do j = 1, sten 
      do i =  stenp1, nx-sten
 
         indsum = i+j+k
!!$ indsum > maxsum and indsum < minsum both impossible!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)
         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 7) ymax,zmin:
  do k = 1, sten 
    do j = ny-sten+1, ny
      do i =  stenp1, nx-sten
 
         indsum = i+j+k
!!$ indsum > maxsum and indsum < minsum both impossible!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)
         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 8) ymax,zmax:
  do k = nz-sten+1, nz
    do j = ny-sten+1, ny
      do i =  stenp1, nx-sten
 
         indsum = i+j+k
!!$ indsum < minsum impossible!
         if(indsum.gt.maxsum) then
            inew = nx - stenp1 + 1
            jnew = ny - stenp1 + 1
            knew = nz - stenp1 + 1
         else
            call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         end if

!!$  Don't poison edges!
         dens(i,j,k) = dens(inew,jnew,knew)
         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 9) xmin,zmin:
  do k = 1, sten 
    do j = stenp1, ny-sten 
      do i = 1, sten 
 
         indsum = i+j+k
!!$ indsum > maxsum impossible!
         if(indsum.lt.minsum) then
            inew = stenp1
            jnew = stenp1
            knew = stenp1
         else
            call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         end if
         
!!$  Don't poison edges!
         dens(i,j,k) = dens(inew,jnew,knew)

         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 10) xmin,zmax:
  do k = nz-sten+1, nz
    do j = stenp1, ny-sten
      do i = 1, sten 

         indsum = i+j+k
!!$ indsum > maxsum and indsum < minsum both impossible!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)
         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 11) xmax,zmin:
  do k = 1, sten 
    do j = stenp1, ny-sten
      do i = nx-sten+1, nx 
 
         indsum = i+j+k
!!$ indsum > maxsum and indsum < minsum both impossible!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)
         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 12) xmax,zmax:
  do k = nz-sten+1, nz
    do j = stenp1, ny-sten
      do i = nx-sten+1, nx 

         indsum = i+j+k
!!$ indsum < minsum impossible!
         if(indsum.gt.maxsum) then
            inew = nx - stenp1 + 1
            jnew = ny - stenp1 + 1
            knew = nz - stenp1 + 1
         else
            call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         end if
                  
!!$  Don't poison edges!
         dens(i,j,k) = dens(inew,jnew,knew)

         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

!!$ Loop over the cubical domain 8 corners:

  !!$ 1) xmin,ymin,zmin:
  do k = 1, sten
    do j = 1, sten
      do i = 1, sten
 
!!$ indsum < minsum guaranteed!

         inew = stenp1
         jnew = stenp1
         knew = stenp1

!!$  Don't poison corners!
         dens(i,j,k) = dens(inew,jnew,knew)
         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 2) xmin,ymin,zmax:
  do k = nz-sten+1, nz
    do j = 1, sten
      do i = 1, sten
 
         indsum = i+j+k
!!$ indsum < maxsum and indsum > minsum guaranteed!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 3) xmin,ymax,zmin:
  do k = 1, sten
    do j = ny-sten+1, ny 
      do i = 1, sten
 
         indsum = i+j+k
!!$ indsum < maxsum and indsum > minsum guaranteed!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 4) xmin,ymax,zmax:
  do k = nz-sten+1, nz
    do j = ny-sten+1, ny
      do i = 1, sten
 
         indsum = i+j+k
!!$ indsum < maxsum and indsum > minsum guaranteed!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 5) xmax,ymin,zmin:
  do k = 1, sten
    do j = 1, sten
      do i = nx-sten+1, nx
 
         indsum = i+j+k
!!$ indsum < maxsum and indsum > minsum guaranteed!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 6) xmax,ymin,zmax:
  do k = nz-sten+1, nz
    do j = 1, sten
      do i = nx-sten+1, nx
 
         indsum = i+j+k
!!$ indsum < maxsum and indsum > minsum guaranteed!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 7) xmax,ymax,zmin:
  do k = 1, sten
    do j = ny-sten+1, ny 
      do i = nx-sten+1, nx
 
         indsum = i+j+k
!!$ indsum < maxsum and indsum > minsum guaranteed!
         call find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)
         dens(i,j,k) = dens(inew,jnew,knew)         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

  !!$ 8) xmax,ymax,zmax:
  do k = nz-sten+1, nz
    do j = ny-sten+1, ny 
      do i = nx-sten+1, nx
 
!!$ indsum > maxsum guaranteed!

         inew = nx - stenp1 + 1
         jnew = ny - stenp1 + 1
         knew = nz - stenp1 + 1

!!$  Don't poison corners!
         dens(i,j,k) = dens(inew,jnew,knew)
         
         sx(i,j,k) = sx(inew,jnew,knew)
         sy(i,j,k) = sy(inew,jnew,knew)
         sz(i,j,k) = sz(inew,jnew,knew)
         tau(i,j,k) = tau(inew,jnew,knew)
         Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
         Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
         Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
         if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,knew)
         endif

      end do 
    end do
  end do 

!!$ Synchronize ghost zones (first time):

  call CCTK_GroupIndex(gindex_tau,"GRHydro::tau")
  call CCTK_GroupIndex(gindex_dens,"GRHydro::dens")
  call CCTK_GroupIndex(gindex_scon,"GRHydro::scon")
  call CCTK_GroupIndex(gindex_Bcons,"GRHydro::Bcons")

  groups(1) = gindex_tau
  groups(2) = gindex_dens
  groups(3) = gindex_scon
  groups(4) = gindex_Bcons

  call CCTK_SyncGroupsI(status,cctkGH,num_groups,groups)
  if(status.lt.0) then
    write(error_message,'(a33,i3,a5,i3,a7)' ) &
    'CCTK_SyncGroupsI returned status ',status,' for ',num_groups,'groups.'
    call CCTK_WARN(CCTK_WARN_ABORT,error_message)
  endif
  
  if(clean_divergence.ne.0) then
    call CCTK_SyncGroup(status,cctkGH,"GRHydro::psidc")
    if(status.lt.0) then
      write(error_message,'(a31,i3,a19)' ) &
      'CCTK_SyncGroup returned status ',status,' for GRHydro::psidc'
      call CCTK_WARN(CCTK_WARN_ABORT,error_message)
    endif
  endif 


!!$ Fix the indsum < minsum area in one go?
  do k=1,minsum-3
     do j=1,minsum-k-2
        do i=1,minsum-k-j-1

           indsum=i+j+k
           if(dens(i,j,k).lt.0.0d0) then
              if(dens(j,i,k).gt.0.0d0) then
                 inew=j
                 jnew=i
                 knew=k
              else if(dens(k,j,i).gt.0.0d0) then
                 inew=k
                 jnew=j
                 knew=i
              else if(dens(i,k,j).gt.0.0d0) then
                 inew=i
                 jnew=k
                 knew=j
              else
                 inew=stenp1
                 jnew=stenp1
                 knew=stenp1
              endif

              dens(i,j,k) = dens(inew,jnew,knew)
              sx(i,j,k) = sx(inew,jnew,knew)
              sy(i,j,k) = sy(inew,jnew,knew)
              sz(i,j,k) = sz(inew,jnew,knew)
              tau(i,j,k) = tau(inew,jnew,knew)
              Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
              Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
              Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
              if(clean_divergence.ne.0) then 
                 psidc(i,j,k)=psidc(inew,jnew,knew)
              endif
           end if

        end do
     end do
  end do

!!$ Fix the indsum > maxsum area in one go?
  do k=nz-3*stenp1+4,nz
     do j=ny-3*stenp1+4+(nz-k),ny
        do i=nx-3*stenp1+4+(nz-k)+(ny-j),nx

           indsum=i+j+k
           xoff=nx-i
           yoff=ny-j
           zoff=nz-k
           if(dens(i,j,k).lt.0.0d0) then

              if(dens(nx-yoff,ny-xoff,k).gt.0.0d0) then
                 inew=nx-yoff
                 jnew=ny-xoff
                 knew=k
              else if(dens(nx-zoff,j,nz-xoff).gt.0.0d0) then
                 inew=nx-zoff
                 jnew=j
                 knew=nz-xoff
              else if(dens(i,ny-zoff,nz-yoff).gt.0.0d0) then
                 inew=i
                 jnew=ny-zoff
                 knew=nz-xoff
              else
                 inew=nx - stenp1 + 1
                 jnew=ny - stenp1 + 1
                 knew=nz - stenp1 + 1
              endif
              
              dens(i,j,k) = dens(inew,jnew,knew)
              sx(i,j,k) = sx(inew,jnew,knew)
              sy(i,j,k) = sy(inew,jnew,knew)
              sz(i,j,k) = sz(inew,jnew,knew)
              tau(i,j,k) = tau(inew,jnew,knew)
              Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
              Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
              Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
              if(clean_divergence.ne.0) then 
                 psidc(i,j,k)=psidc(inew,jnew,knew)
              endif
           end if
           
        end do
     end do
  end do
  

!!$ Fix the ymin face in the region indsum < minsum
!!$  do k = stenp1, nz-sten
!!$    do j = 1, sten
!!$      do i =  stenp1, nx-sten
!!$
!!$        indsum = i+j
!!$        if(indsum.lt.minsum.and.dens(i,j,k).lt.0.0d0) then
!!$          inew = j
!!$          jnew = i
!!$          if(dens(inew,jnew,k).lt.0.0d0) then
!!$            inew = stenp1
!!$            jnew = stenp1
!!$          endif 
!!$           
!!$          dens(i,j,k) = dens(inew,jnew,k)
!!$          sx(i,j,k) = sx(inew,jnew,k)
!!$          sy(i,j,k) = sy(inew,jnew,k)
!!$          sz(i,j,k) = sz(inew,jnew,k)
!!$          tau(i,j,k) = tau(inew,jnew,k)
!!$          Bconsx(i,j,k)=Bconsx(inew,jnew,k)
!!$          Bconsy(i,j,k)=Bconsy(inew,jnew,k)
!!$          Bconsz(i,j,k)=Bconsz(inew,jnew,k)
!!$          if(clean_divergence.ne.0) then 
!!$            psidc(i,j,k)=psidc(inew,jnew,k)
!!$          endif
!!$        end if
!!$
!!$      end do 
!!$    end do
!!$  end do 

!!$ Fix the xmin face in the region indsum < minsum
!!$  do k = stenp1, nz-sten
!!$    do j = stenp1, ny-sten
!!$      do i = 1, sten
!!$
!!$        indsum = i+j
!!$        if(indsum.lt.minsum.and.dens(i,j,k).lt.0.0d0) then
!!$          inew = j
!!$          jnew = i
!!$          if(dens(inew,jnew,k).lt.0.0d0) then
!!$            inew = stenp1
!!$            jnew = stenp1
!!$          endif 
!!$           
!!$          dens(i,j,k) = dens(inew,jnew,k)
!!$          sx(i,j,k) = sx(inew,jnew,k)
!!$          sy(i,j,k) = sy(inew,jnew,k)
!!$          sz(i,j,k) = sz(inew,jnew,k)
!!$          tau(i,j,k) = tau(inew,jnew,k)
!!$          Bconsx(i,j,k)=Bconsx(inew,jnew,k)
!!$          Bconsy(i,j,k)=Bconsy(inew,jnew,k)
!!$          Bconsz(i,j,k)=Bconsz(inew,jnew,k)
!!$          if(clean_divergence.ne.0) then 
!!$            psidc(i,j,k)=psidc(inew,jnew,k)
!!$          endif
!!$        end if
!!$
!!$
!!$      end do 
!!$    end do
!!$  end do 

!!$ Fix the ymax face in the region indsum > maxsum
!!$  do k = stenp1, nz-sten
!!$    do j = ny-sten+1, ny
!!$      do i = stenp1, nx-sten
!!$
!!$        indsum = i+j
!!$        if(indsum.gt.maxsum.and.dens(i,j,k).lt.0.0d0) then
!!$          inew = j-ny+nx
!!$          jnew = i-nx+ny
!!$          if(dens(inew,jnew,k).lt.0.0d0) then
!!$            inew = nx - stenp1
!!$            jnew = ny - stenp1
!!$          endif 
!!$           
!!$          dens(i,j,k) = dens(inew,jnew,k)
!!$          sx(i,j,k) = sx(inew,jnew,k)
!!$          sy(i,j,k) = sy(inew,jnew,k)
!!$          sz(i,j,k) = sz(inew,jnew,k)
!!$          tau(i,j,k) = tau(inew,jnew,k)
!!$          Bconsx(i,j,k)=Bconsx(inew,jnew,k)
!!$          Bconsy(i,j,k)=Bconsy(inew,jnew,k)
!!$          Bconsz(i,j,k)=Bconsz(inew,jnew,k)
!!$          if(clean_divergence.ne.0) then 
!!$            psidc(i,j,k)=psidc(inew,jnew,k)
!!$          endif
!!$        endif
!!$
!!$      end do 
!!$    end do
!!$  end do 

!!$ Fix the xmax face in the region indsum > maxsum
!!$  do k = stenp1, nz-sten
!!$    do j = stenp1, ny-sten
!!$      do i = nx-sten+1, nx
!!$
!!$        indsum = i+j
!!$        if(indsum.gt.maxsum.and.dens(i,j,k).lt.0.0d0) then
!!$          inew = j-ny+nx
!!$          jnew = i-nx+ny
!!$          if(dens(inew,jnew,k).lt.0.0d0) then
!!$            inew = nx - stenp1
!!$            jnew = ny - stenp1
!!$          endif 
!!$           
!!$          dens(i,j,k) = dens(inew,jnew,k)
!!$          sx(i,j,k) = sx(inew,jnew,k)
!!$          sy(i,j,k) = sy(inew,jnew,k)
!!$          sz(i,j,k) = sz(inew,jnew,k)
!!$          tau(i,j,k) = tau(inew,jnew,k)
!!$          Bconsx(i,j,k)=Bconsx(inew,jnew,k)
!!$          Bconsy(i,j,k)=Bconsy(inew,jnew,k)
!!$          Bconsz(i,j,k)=Bconsz(inew,jnew,k)
!!$          if(clean_divergence.ne.0) then 
!!$            psidc(i,j,k)=psidc(inew,jnew,k)
!!$          endif
!!$        endif
!!$
!!$      end do 
!!$    end do
!!$  end do 

!!$ Synchronize ghost zones (second time):

  call CCTK_SyncGroupsI(status,cctkGH,num_groups,groups)
  if(status.lt.0) then
    write(error_message,'(a33,i3,a5,i3,a7)' ) &
    'CCTK_SyncGroupsI returned status ',status,' for ',num_groups,'groups.'
    call CCTK_WARN(CCTK_WARN_ABORT,error_message)
  endif
  
  if(clean_divergence.ne.0) then
    call CCTK_SyncGroup(status,cctkGH,"GRHydro::psidc")
    if(status.lt.0) then
      write(error_message,'(a31,i3,a19)' ) &
      'CCTK_SyncGroup returned status ',status,' for GRHydro::psidc'
      call CCTK_WARN(CCTK_WARN_ABORT,error_message)
    endif
  endif 

!!$  do k=1,nz
!!$     if(k.lt.stenp1)then
!!$              zoff=k-stenp1
!!$           else if(k.gt.nz-stenp1+1) then
!!$              zoff=k-(nz-stenp1+1)
!!$           else
!!$              zoff=0
!!$           endif
!!$
!!$     do j=1,ny
!!$        if(j.lt.stenp1)then
!!$           yoff=j-stenp1
!!$        else if(j.gt.ny-stenp1+1) then
!!$           yoff=j-(ny-stenp1+1)
!!$        else
!!$           yoff=0
!!$        endif
!!$
!!$        do i=1,nx
!!$           if(i.lt.stenp1) then
!!$              xoff=i-stenp1
!!$           else if(i.gt.nx-stenp1+1) then
!!$              xoff=i-(nx-stenp1+1)
!!$           else
!!$              xoff=0
!!$           endif
!!$
!!$           indsum = i+j+k
!!$           
!!$           if( (xoff.ne.0.or.yoff.ne.0.or.zoff.ne.0) .and. &
!!$                indsum.ge.minsum.and.indsum.le.maxsum) then
!!$    We can map the point to the interior diagonal, orthogonal to the shock.
!!$
!!$              inew=indsum/3
!!$              jnew=(indsum-inew)/2
!!$              knew=indsum-inew-jnew
!!$              
!!$              dens(i,j,k) = dens(inew,jnew,knew)
!!$              sx(i,j,k) = sx(inew,jnew,knew)
!!$              sy(i,j,k) = sy(inew,jnew,knew)
!!$              sz(i,j,k) = sz(inew,jnew,knew)
!!$              tau(i,j,k) = tau(inew,jnew,knew)
!!$              Bconsx(i,j,k)=Bconsx(inew,jnew,knew)
!!$              Bconsy(i,j,k)=Bconsy(inew,jnew,knew)
!!$              Bconsz(i,j,k)=Bconsz(inew,jnew,knew)
!!$             if(clean_divergence.ne.0) then 
!!$               psidc(i,j,k)=psidc(inew,jnew,knew)
!!$             endif
!!$
!!$           endif
!!$           
!!$        enddo
!!$     enddo
!!$  enddo
 
end subroutine GRHydro_Diagshock_BoundaryM

subroutine GRHydro_Diagshock2D_BoundaryM(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, kc, nx, ny, nz, sten, stenp1, minsum, maxsum, inew, jnew, knew
  CCTK_INT :: xoff,yoff,zoff,indsum,numoff
  CCTK_REAL :: det
  CCTK_INT :: status
  character(len=200) :: error_message
  integer :: gindex_tau, gindex_dens, gindex_scon, gindex_Bcons
  CCTK_INT, parameter :: num_groups = 4
  CCTK_INT :: groups(num_groups)
  
  sten=GRHydro_stencil
  stenp1=GRHydro_stencil + 1
  
  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)
  
  minsum = 2*stenp1
  maxsum = nx+ny-2*sten
  
  xoff=0
  yoff=0
  zoff=0

!!$ Loop over the cubical domain 6 faces:

  !!$ 1) xmin:
  do k = stenp1, nz-sten
    do j = stenp1, ny-sten
      do i = 1, sten

        xoff=i-stenp1
        yoff=0
        zoff=0
        indsum = i+j
        inew = i - xoff
        jnew = j + xoff
        if(indsum.lt.minsum) then
          inew = stenp1
          jnew = stenp1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else if(indsum.gt.maxsum) then
          inew = nx - sten
          jnew = ny - sten
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else
          dens(i,j,k) = dens(inew,jnew,k)
        end if
           
        sx(i,j,k) = sx(inew,jnew,k)
        sy(i,j,k) = sy(inew,jnew,k)
        sz(i,j,k) = sz(inew,jnew,k)
        tau(i,j,k) = tau(inew,jnew,k)
        Bconsx(i,j,k)=Bconsx(inew,jnew,k)
        Bconsy(i,j,k)=Bconsy(inew,jnew,k)
        Bconsz(i,j,k)=Bconsz(inew,jnew,k)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,k)
        endif

      end do 
    end do
  end do 

  !!$ 2) xmax:
  do k = stenp1, nz-sten
    do j = stenp1, ny-sten
      do i = nx-sten+1, nx

        xoff=i-(nx-stenp1+1)
        yoff=0
        zoff=0
        indsum = i+j
        inew = i - xoff
        jnew = j + xoff
        if(indsum.lt.minsum) then
          inew = stenp1
          jnew = stenp1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else if(indsum.gt.maxsum) then
          inew = nx - sten
          jnew = ny - sten
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else
          dens(i,j,k) = dens(inew,jnew,k)
        end if
           
        sx(i,j,k) = sx(inew,jnew,k)
        sy(i,j,k) = sy(inew,jnew,k)
        sz(i,j,k) = sz(inew,jnew,k)
        tau(i,j,k) = tau(inew,jnew,k)
        Bconsx(i,j,k)=Bconsx(inew,jnew,k)
        Bconsy(i,j,k)=Bconsy(inew,jnew,k)
        Bconsz(i,j,k)=Bconsz(inew,jnew,k)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,k)
        endif

      end do 
    end do
  end do 

  !!$ 3) ymin:
  do k = stenp1, nz-sten
    do j = 1, sten
      do i =  stenp1, nx-sten

        xoff=0
        yoff=j-stenp1
        zoff=0
        indsum = i+j
        inew = i + yoff
        jnew = j - yoff
        if(indsum.lt.minsum) then
          inew = stenp1
          jnew = stenp1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else if(indsum.gt.maxsum) then
          inew = nx - sten
          jnew = ny - sten
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else
          dens(i,j,k) = dens(inew,jnew,k)
        end if
           
        sx(i,j,k) = sx(inew,jnew,k)
        sy(i,j,k) = sy(inew,jnew,k)
        sz(i,j,k) = sz(inew,jnew,k)
        tau(i,j,k) = tau(inew,jnew,k)
        Bconsx(i,j,k)=Bconsx(inew,jnew,k)
        Bconsy(i,j,k)=Bconsy(inew,jnew,k)
        Bconsz(i,j,k)=Bconsz(inew,jnew,k)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,k)
        endif

      end do 
    end do
  end do 

  !!$ 4) ymax:
  do k = stenp1, nz-sten
    do j = ny-sten+1, ny
      do i = stenp1, nx-sten

        xoff=0
        yoff=j-(ny-stenp1+1)
        zoff=0
        indsum = i+j
        inew = i + yoff
        jnew = j - yoff
        if(indsum.lt.minsum) then
          inew = stenp1
          jnew = stenp1
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else if(indsum.gt.maxsum) then
          inew = nx - sten
          jnew = ny - sten
          dens(i,j,k) = -1.0d0 !!$ poison at shock propagation direction corners
        else
          dens(i,j,k) = dens(inew,jnew,k)
        end if
           
        sx(i,j,k) = sx(inew,jnew,k)
        sy(i,j,k) = sy(inew,jnew,k)
        sz(i,j,k) = sz(inew,jnew,k)
        tau(i,j,k) = tau(inew,jnew,k)
        Bconsx(i,j,k)=Bconsx(inew,jnew,k)
        Bconsy(i,j,k)=Bconsy(inew,jnew,k)
        Bconsz(i,j,k)=Bconsz(inew,jnew,k)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,k)
        endif

      end do 
    end do
  end do 

  !!$ 5) zmin:
  do k = 1, sten 
    do j = stenp1, ny-sten
      do i =  stenp1, nx-sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 6) zmax:
  do k = nz-sten+1, nz
    do j = stenp1, ny-sten
      do i = stenp1, nx-sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

!!$ Loop over the cubical domain 12 edges:

  !!$ 1) xmin,ymin:
  do k = stenp1, nz-sten
    do j = 1, sten
      do i = 1, sten

        !!$ We already know that for this edge indsum.lt.minsum.
        inew = stenp1
        jnew = stenp1
           
        dens(i,j,k) = dens(inew,jnew,k)
        sx(i,j,k) = sx(inew,jnew,k)
        sy(i,j,k) = sy(inew,jnew,k)
        sz(i,j,k) = sz(inew,jnew,k)
        tau(i,j,k) = tau(inew,jnew,k)
        Bconsx(i,j,k)=Bconsx(inew,jnew,k)
        Bconsy(i,j,k)=Bconsy(inew,jnew,k)
        Bconsz(i,j,k)=Bconsz(inew,jnew,k)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,k)
        endif

      end do 
    end do
  end do 

  !!$ 2) xmin,ymax:
  do k = stenp1, nz-sten
    do j =  ny-sten+1, ny
      do i = 1, sten

        xoff=i-stenp1
        yoff=j-(ny-stenp1+1)
        zoff=0
 
        numoff = max(abs(xoff),abs(yoff))
        if( abs(xoff).eq.numoff) then
          inew = i + numoff
          jnew = j - numoff
        else
          jnew = j - numoff
          inew = i + numoff
        endif  

        dens(i,j,k) = dens(inew,jnew,k)
        sx(i,j,k) = sx(inew,jnew,k)
        sy(i,j,k) = sy(inew,jnew,k)
        sz(i,j,k) = sz(inew,jnew,k)
        tau(i,j,k) = tau(inew,jnew,k)
        Bconsx(i,j,k)=Bconsx(inew,jnew,k)
        Bconsy(i,j,k)=Bconsy(inew,jnew,k)
        Bconsz(i,j,k)=Bconsz(inew,jnew,k)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,k)
        endif

      end do 
    end do
  end do 

  !!$ 3) xmax,ymin:
  do k = stenp1, nz-sten
    do j = 1, sten
      do i = nx-sten+1, nx 

        xoff=i-(nx-stenp1+1)
        yoff=j-stenp1
        zoff=0
        numoff = max(abs(xoff),abs(yoff))
        if( abs(xoff).eq.numoff) then
          inew = i - numoff
          jnew = j + numoff
        else
          jnew = j + numoff
          inew = i - numoff
        endif  
           
        dens(i,j,k) = dens(inew,jnew,k)
        sx(i,j,k) = sx(inew,jnew,k)
        sy(i,j,k) = sy(inew,jnew,k)
        sz(i,j,k) = sz(inew,jnew,k)
        tau(i,j,k) = tau(inew,jnew,k)
        Bconsx(i,j,k)=Bconsx(inew,jnew,k)
        Bconsy(i,j,k)=Bconsy(inew,jnew,k)
        Bconsz(i,j,k)=Bconsz(inew,jnew,k)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,k)
        endif

      end do 
    end do
  end do 

  !!$ 4) xmax,ymax:
  do k = stenp1, nz-sten
    do j = ny-sten+1, ny 
      do i = nx-sten+1, nx 

        !!$ We already know that for this edge indsum.gt.maxsum
        inew = nx - sten
        jnew = ny - sten
          
        dens(i,j,k) = dens(inew,jnew,k)
        sx(i,j,k) = sx(inew,jnew,k)
        sy(i,j,k) = sy(inew,jnew,k)
        sz(i,j,k) = sz(inew,jnew,k)
        tau(i,j,k) = tau(inew,jnew,k)
        Bconsx(i,j,k)=Bconsx(inew,jnew,k)
        Bconsy(i,j,k)=Bconsy(inew,jnew,k)
        Bconsz(i,j,k)=Bconsz(inew,jnew,k)
        if(clean_divergence.ne.0) then 
          psidc(i,j,k)=psidc(inew,jnew,k)
        endif

      end do 
    end do
  end do 

  !!$ 5) ymin,zmin:
  do k = 1, sten 
    do j = 1, sten 
      do i =  stenp1, nx-sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 6) ymin,zmax:
  do k = nz-sten+1, nz
    do j = 1, sten 
      do i =  stenp1, nx-sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 7) ymax,zmin:
  do k = 1, sten 
    do j = ny-sten+1, ny
      do i =  stenp1, nx-sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 8) ymax,zmax:
  do k = nz-sten+1, nz
    do j = ny-sten+1, ny
      do i =  stenp1, nx-sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 9) xmin,zmin:
  do k = 1, sten 
    do j = stenp1, ny-sten 
      do i = 1, sten 
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 10) xmin,zmax:
  do k = nz-sten+1, nz
    do j = stenp1, ny-sten
      do i = 1, sten 
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 11) xmax,zmin:
  do k = 1, sten 
    do j = stenp1, ny-sten
      do i = nx-sten+1, nx 
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 12) xmax,zmax:
  do k = nz-sten+1, nz
    do j = stenp1, ny-sten
      do i = nx-sten+1, nx 
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

!!$ Loop over the cubical domain 8 corners:

  !!$ 1) xmin,ymin,zmin:
  do k = 1, sten
    do j = 1, sten
      do i = 1, sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 2) xmin,ymin,zmax:
  do k = nz-sten+1, nz
    do j = 1, sten
      do i = 1, sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 3) xmin,ymax,zmin:
  do k = 1, sten
    do j = ny-sten+1, ny 
      do i = 1, sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 4) xmin,ymax,zmax:
  do k = nz-sten+1, nz
    do j = ny-sten+1, ny
      do i = 1, sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 5) xmax,ymin,zmin:
  do k = 1, sten
    do j = 1, sten
      do i = nx-sten+1, nx
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 6) xmax,ymin,zmax:
  do k = nz-sten+1, nz
    do j = 1, sten
      do i = nx-sten+1, nx
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 7) xmax,ymax,zmin:
  do k = 1, sten
    do j = ny-sten+1, ny 
      do i = nx-sten+1, nx
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 8) xmax,ymax,zmax:
  do k = nz-sten+1, nz
    do j = ny-sten+1, ny 
      do i = nx-sten+1, nx
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

!!$ Synchronize ghost zones (first time):

  call CCTK_GroupIndex(gindex_tau,"GRHydro::tau")
  call CCTK_GroupIndex(gindex_dens,"GRHydro::dens")
  call CCTK_GroupIndex(gindex_scon,"GRHydro::scon")
  call CCTK_GroupIndex(gindex_Bcons,"GRHydro::Bcons")

  groups(1) = gindex_tau
  groups(2) = gindex_dens
  groups(3) = gindex_scon
  groups(4) = gindex_Bcons

  call CCTK_SyncGroupsI(status,cctkGH,num_groups,groups)
  if(status.lt.0) then
    write(error_message,'(a33,i3,a5,i3,a7)' ) &
    'CCTK_SyncGroupsI returned status ',status,' for ',num_groups,'groups.'
    call CCTK_WARN(CCTK_WARN_ABORT,error_message)
  endif
  
  if(clean_divergence.ne.0) then
    call CCTK_SyncGroup(status,cctkGH,"GRHydro::psidc")
    if(status.lt.0) then
      write(error_message,'(a31,i3,a19)' ) &
      'CCTK_SyncGroup returned status ',status,' for GRHydro::psidc'
      call CCTK_WARN(CCTK_WARN_ABORT,error_message)
    endif
  endif 

!!$ Fix the ymin face in the region indsum < minsum
  do k = stenp1, nz-sten
    do j = 1, sten
      do i =  stenp1, nx-sten

        indsum = i+j
        if(indsum.lt.minsum.and.dens(i,j,k).lt.0.0d0) then
          inew = j
          jnew = i
          if(dens(inew,jnew,k).lt.0.0d0) then
            inew = stenp1
            jnew = stenp1
          endif 
           
          dens(i,j,k) = dens(inew,jnew,k)
          sx(i,j,k) = sx(inew,jnew,k)
          sy(i,j,k) = sy(inew,jnew,k)
          sz(i,j,k) = sz(inew,jnew,k)
          tau(i,j,k) = tau(inew,jnew,k)
          Bconsx(i,j,k)=Bconsx(inew,jnew,k)
          Bconsy(i,j,k)=Bconsy(inew,jnew,k)
          Bconsz(i,j,k)=Bconsz(inew,jnew,k)
          if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,k)
          endif
        end if

      end do 
    end do
  end do 

!!$ Fix the xmin face in the region indsum < minsum
  do k = stenp1, nz-sten
    do j = stenp1, ny-sten
      do i = 1, sten

        indsum = i+j
        if(indsum.lt.minsum.and.dens(i,j,k).lt.0.0d0) then
          inew = j
          jnew = i
          if(dens(inew,jnew,k).lt.0.0d0) then
            inew = stenp1
            jnew = stenp1
          endif 
           
          dens(i,j,k) = dens(inew,jnew,k)
          sx(i,j,k) = sx(inew,jnew,k)
          sy(i,j,k) = sy(inew,jnew,k)
          sz(i,j,k) = sz(inew,jnew,k)
          tau(i,j,k) = tau(inew,jnew,k)
          Bconsx(i,j,k)=Bconsx(inew,jnew,k)
          Bconsy(i,j,k)=Bconsy(inew,jnew,k)
          Bconsz(i,j,k)=Bconsz(inew,jnew,k)
          if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,k)
          endif
        end if


      end do 
    end do
  end do 

!!$ Fix the ymax face in the region indsum > maxsum
  do k = stenp1, nz-sten
    do j = ny-sten+1, ny
      do i = stenp1, nx-sten

        indsum = i+j
        if(indsum.gt.maxsum.and.dens(i,j,k).lt.0.0d0) then
          inew = j-ny+nx
          jnew = i-nx+ny
          if(dens(inew,jnew,k).lt.0.0d0) then
            inew = nx - sten
            jnew = ny - sten
          endif 
           
          dens(i,j,k) = dens(inew,jnew,k)
          sx(i,j,k) = sx(inew,jnew,k)
          sy(i,j,k) = sy(inew,jnew,k)
          sz(i,j,k) = sz(inew,jnew,k)
          tau(i,j,k) = tau(inew,jnew,k)
          Bconsx(i,j,k)=Bconsx(inew,jnew,k)
          Bconsy(i,j,k)=Bconsy(inew,jnew,k)
          Bconsz(i,j,k)=Bconsz(inew,jnew,k)
          if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,k)
          endif
        endif

      end do 
    end do
  end do 

!!$ Fix the xmax face in the region indsum > maxsum
  do k = stenp1, nz-sten
    do j = stenp1, ny-sten
      do i = nx-sten+1, nx

        indsum = i+j
        if(indsum.gt.maxsum.and.dens(i,j,k).lt.0.0d0) then
          inew = j-ny+nx
          jnew = i-nx+ny
          if(dens(inew,jnew,k).lt.0.0d0) then
            inew = nx - sten
            jnew = ny - sten
          endif 
           
          dens(i,j,k) = dens(inew,jnew,k)
          sx(i,j,k) = sx(inew,jnew,k)
          sy(i,j,k) = sy(inew,jnew,k)
          sz(i,j,k) = sz(inew,jnew,k)
          tau(i,j,k) = tau(inew,jnew,k)
          Bconsx(i,j,k)=Bconsx(inew,jnew,k)
          Bconsy(i,j,k)=Bconsy(inew,jnew,k)
          Bconsz(i,j,k)=Bconsz(inew,jnew,k)
          if(clean_divergence.ne.0) then 
            psidc(i,j,k)=psidc(inew,jnew,k)
          endif
        endif

      end do 
    end do
  end do 

!!$ Fix the upper and lower (5-12 below) domain edges since 
!!$ they still contain poison got from the faces in the initial
!!$ step: 

  !!$ 5) ymin,zmin:
  do k = 1, sten 
    do j = 1, sten 
      do i =  stenp1, nx-sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 6) ymin,zmax:
  do k = nz-sten+1, nz
    do j = 1, sten 
      do i =  stenp1, nx-sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 7) ymax,zmin:
  do k = 1, sten 
    do j = ny-sten+1, ny
      do i =  stenp1, nx-sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 8) ymax,zmax:
  do k = nz-sten+1, nz
    do j = ny-sten+1, ny
      do i =  stenp1, nx-sten
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 9) xmin,zmin:
  do k = 1, sten 
    do j = stenp1, ny-sten 
      do i = 1, sten 
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 10) xmin,zmax:
  do k = nz-sten+1, nz
    do j = stenp1, ny-sten
      do i = 1, sten 
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 11) xmax,zmin:
  do k = 1, sten 
    do j = stenp1, ny-sten
      do i = nx-sten+1, nx 
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

  !!$ 12) xmax,zmax:
  do k = nz-sten+1, nz
    do j = stenp1, ny-sten
      do i = nx-sten+1, nx 
 
        kc = nz/2

        dens(i,j,k) = dens(i,j,kc)
        sx(i,j,k) = sx(i,j,kc)
        sy(i,j,k) = sy(i,j,kc)
        sz(i,j,k) = sz(i,j,kc)
        tau(i,j,k) = tau(i,j,kc)
        Bconsx(i,j,k)=Bconsx(i,j,kc)
        Bconsy(i,j,k)=Bconsy(i,j,kc)
        Bconsz(i,j,k)=Bconsz(i,j,kc)
        if(clean_divergence.ne.0) then
          psidc(i,j,k)=psidc(i,j,kc)
        endif

      end do 
    end do
  end do 

!!$ Synchronize ghost zones (second time):

  call CCTK_SyncGroupsI(status,cctkGH,num_groups,groups)
  if(status.lt.0) then
    write(error_message,'(a33,i3,a5,i3,a7)' ) &
    'CCTK_SyncGroupsI returned status ',status,' for ',num_groups,'groups.'
    call CCTK_WARN(CCTK_WARN_ABORT,error_message)
  endif
  
  if(clean_divergence.ne.0) then
    call CCTK_SyncGroup(status,cctkGH,"GRHydro::psidc")
    if(status.lt.0) then
      write(error_message,'(a31,i3,a19)' ) &
      'CCTK_SyncGroup returned status ',status,' for GRHydro::psidc'
      call CCTK_WARN(CCTK_WARN_ABORT,error_message)
    endif
  endif 
        
!!$  do k=1,nz
!!$     if(k.lt.stenp1)then
!!$        zoff=k-stenp1
!!$     else if(k.gt.nz-stenp1+1) then
!!$        zoff=k-(nz-stenp1+1)
!!$     else
!!$        zoff=0
!!$     endif
!!$
!!$     do j=1,ny
!!$        if(j.lt.stenp1)then
!!$           yoff=j-stenp1
!!$        else if(j.gt.ny-stenp1+1) then
!!$           yoff=j-(ny-stenp1+1)
!!$        else
!!$           yoff=0
!!$        endif
!!$
!!$        do i=1,nx
!!$           if(i.lt.stenp1) then
!!$              xoff=i-stenp1
!!$           else if(i.gt.nx-stenp1+1) then
!!$              xoff=i-(nx-stenp1+1)
!!$           else
!!$              xoff=0
!!$           endif
!!$  
!!$        indsum = i+j
!!$        
!!$        if(xoff.ne.0.or.yoff.ne.0) then
!!$
!!$          if(indsum.ge.minsum.and.indsum.le.maxsum) then
!!$
!!$           numoff = max(abs(xoff),abs(yoff))
!!$           if( abs(xoff).eq.numoff) then
!!$             if(xoff.gt.0) then
!!$               inew = i - numoff
!!$               jnew = j + numoff
!!$             else
!!$               inew = i + numoff
!!$               jnew = j - numoff
!!$             endif
!!$           else
!!$             if(yoff.gt.0) then
!!$               jnew = j - numoff
!!$               inew = i + numoff
!!$             else
!!$               jnew = j + numoff
!!$               inew = i - numoff
!!$             endif
!!$           endif  
!!$!!$ Note that the following two conditions helps but
!!$!!$ don't solve the problem when running in several
!!$!!$ processors
!!$         else if(indsum.lt.minsum) then
!!$           inew = stenp1
!!$           jnew = stenp1
!!$
!!$         else if(indsum.gt.maxsum) then
!!$           inew = nx - stenp1
!!$           jnew = ny - stenp1
!!$         end if
!!$           
!!$           dens(i,j,k) = dens(inew,jnew,k)
!!$           sx(i,j,k) = sx(inew,jnew,k)
!!$           sy(i,j,k) = sy(inew,jnew,k)
!!$           sz(i,j,k) = sz(inew,jnew,k)
!!$           tau(i,j,k) = tau(inew,jnew,k)
!!$           Bconsx(i,j,k)=Bconsx(inew,jnew,k)
!!$           Bconsy(i,j,k)=Bconsy(inew,jnew,k)
!!$           Bconsz(i,j,k)=Bconsz(inew,jnew,k)
!!$           if(clean_divergence.ne.0) then 
!!$              psidc(i,j,k)=psidc(inew,jnew,k)
!!$           endif
!!$
!!$        else if( zoff.ne.0) then
!!$ 
!!$           kc = nz/2
!!$
!!$           dens(i,j,k) = dens(i,j,kc)
!!$           sx(i,j,k) = sx(i,j,kc)
!!$           sy(i,j,k) = sy(i,j,kc)
!!$           sz(i,j,k) = sz(i,j,kc)
!!$           tau(i,j,k) = tau(i,j,kc)
!!$           Bconsx(i,j,k)=Bconsx(i,j,kc)
!!$           Bconsy(i,j,k)=Bconsy(i,j,kc)
!!$           Bconsz(i,j,k)=Bconsz(i,j,kc)
!!$           if(clean_divergence.ne.0) then
!!$              psidc(i,j,k)=psidc(i,j,kc)
!!$           endif
!!$           
!!$        endif
!!$        
!!$        enddo
!!$     enddo
!!$  enddo
  
end subroutine GRHydro_Diagshock2D_BoundaryM

subroutine find_mapped_point(i,j,k,nx,ny,nz,stenp1,inew,jnew,knew)

!!$ Find the nearest mapped point in the interior, assuming it exists

  implicit none
  CCTK_INT :: i,j,k,n,nx,ny,nz,stenp1
  CCTK_INT :: xoff,yoff,zoff,indsum,minsum,maxsum
  CCTK_INT :: inew,jnew,knew,dspace,newsum
  
  minsum = 3*stenp1
  maxsum = nx+ny+nz - 3*(stenp1-1)

  indsum = i+j+k

  if(indsum.lt.minsum.or.indsum.gt.maxsum)write(6,*)'HUGE ERROR - ILLEGAL INDEX SUM!!!!!!'

  if(i.lt.stenp1)then
     xoff = i - stenp1 
  else if(i.gt.nx-stenp1+1) then
     xoff=i - (nx-stenp1+1)
  else
     xoff=0
  endif
  
  if(j.lt.stenp1)then
     yoff = j - stenp1 
  else if(j.gt.ny-stenp1+1) then
     yoff=j - (ny-stenp1+1)
  else
     yoff=0
  endif
     
  if(k.lt.stenp1)then
     zoff = k - stenp1 
  else if(k.gt.nz-stenp1+1) then
     zoff=k-(nz-stenp1+1)
  else
     zoff=0
  endif
  
  if(xoff.eq.0.and.yoff.eq.0.and.zoff.eq.0) then
     write(6,*)'Why did you try to map an interior point?'
     inew=i
     jnew=j
     knew=k
     return
  else
     
!!$ We have something to actually do!
     
     inew = i-xoff
     jnew = j-yoff
     knew = k-zoff
     dspace = xoff + yoff + zoff
     
     do n=1,abs(dspace)
        
        if(dspace.lt.0) then
           
!!$     dspace negative; point sum corrected upward
!!$     need to move other coords down
           
           if(inew.gt.stenp1) then
              inew = inew - 1
           else if(jnew.gt.stenp1) then
              jnew = jnew - 1
           else if (knew.gt.stenp1) then
              knew = knew - 1
           else
              write(6,*)'Big error!!!!'
           endif
           
        else if (dspace.gt.0) then
           
!!$     dspace positive; point sum corrected downward
!!$     need to move other coords up
           
           if(inew.lt.nx-stenp1+1) then
              inew=inew+1
           else if(jnew.lt.ny-stenp1+1) then
              jnew=jnew+1
           else if(knew.lt.nz-stenp1+1) then
              knew=knew+1
           else
              write(6,*)'Big error2!!!!'
           endif

        end if

     end do
     
     newsum = inew+jnew+knew
     
     if(inew.lt.stenp1.or.inew.gt.(nx-(stenp1-1)).or. &
          jnew.lt.stenp1.or.jnew.gt.(ny-(stenp1-1)).or. &
          knew.lt.stenp1.or.knew.gt.(nz-(stenp1-1)).or. &
          newsum.ne.indsum)write(6,*)'Big error 3!!!!'
     
  end if

  return

end subroutine find_mapped_point


```

GRHydro_Bondi.c:
```
 /*@@
   @file      GRHydro_Bondi.c 
   @date      Wed Jan 13 13:00:49 EST 2010
   @author    Scott C. Noble
   @desc 
   Hydro initial data for the relativistic Bondi solution about 
   a single Schwarzschild black hole. 
   @enddesc 
 @@*/

/***********************************************************************************/
/***********************************************************************************/
/***********************************************************************************
   Calculates the Bondi solution, or the spherically symmetric hydrostationary 
   solution to a fluid on a static fixed background spacetime. We assume that one can
   calculate a radius "r" from the grid and that with respect to this radial coordinate, 
   the solution satisfies 

   d (\rho u^r) / dr    = 0 

   Assumes that the equation of state is  P = K \rho^\Gamma   and K  is set by 
   the location of the sonic point.     


 -- Implicitly assumes that there is no spin in the geometry as there is no Bondi 
    solution for spinning black holes.  If a spin is specified, a spherically symmetric 
    is still assumed but the 4-velocity is set consistently with the spinning spacetime. 

***********************************************************************************/
/***********************************************************************************/
/***********************************************************************************/


#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Parameters.h"
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <assert.h>

// set to 1 to tracing output
#define LTRACE   1


/* Mnemonics: */

#define NDIM (4)  /* Number of spacetime dimensions */

/* mnemonics for dimensional indices */
#define TT      (0)     
#define RR      (1)
#define TH      (2)
#define PH      (3)

/* mnemonics for dimensional indices */
#define XX      (1)
#define YY      (2)
#define ZZ      (3)

/* mnemonics for coordinate system choice */
#define COORD_BOYERLINDQUIST (0)
#define COORD_KERRSCHILD     (1)
#define COORD_ISOTROPIC      (2)

/*  Macros:  */
#define DLOOP1     for(i=0  ;i<NDIM ;i++)
#define DLOOP2     for(i=0  ;i<NDIM ;i++) for(j=0  ;j<NDIM ;j++)


#if !defined(__INTEL_COMPILER)
# define LOCAL_SINCOS
# define sincos( theta_ , sth_ , cth_ )  {  *(sth_) = sin((theta_)) ;  *(cth_) = cos((theta_)) ;  }
#endif


//Newton-Raphson parameters:
#define NEWT_DIM_B        (1      )
#define MAX_NEWT_ITER_B   (30     )    /* Max. # of Newton-Raphson iterations for find_root_2D(); */
#define NEWT_TOL_B        (1.0e-15)    /* Min. of tolerance allowed for Newton-Raphson iterations */
#define MIN_NEWT_TOL_B    (1.0e-10)    /* Max. of tolerance allowed for Newton-Raphson iterations */
#define EXTRA_NEWT_ITER_B (2      )
#define SMALL_BONDI (1.e-20)


static CCTK_REAL  Mdot, rs, vs_sq, vs, cs_sq, cs, rhos, hs, K, Qdot, gamma_eos, r_sol;
static CCTK_REAL  M, a, asq, Msq; 
static CCTK_REAL  x_cen, y_cen, z_cen;
static unsigned short int coord_type; 


/******************************************************************************
  bl_to_ks_con():
  ----------
       -- transforms a contravariant vector in BL coordinates to KS coordinates;
 ******************************************************************************/
static void bl_to_ks_con(CCTK_REAL *x, CCTK_REAL blcon[], CCTK_REAL kscon[] )
{
  CCTK_REAL delta_m1, dtKS_drBL, dphiKS_drBL;
  
  delta_m1 = 1./( x[RR] * ( x[RR] - 2*M ) + asq );
  dtKS_drBL   = 2*M*x[RR] * delta_m1; 
  dphiKS_drBL = a * delta_m1;

  kscon[TT] = blcon[TT]  +  blcon[RR] * dtKS_drBL;
  kscon[RR] = blcon[RR];
  kscon[TH] = blcon[TH];
  kscon[PH] = blcon[PH]  +  blcon[RR] * dphiKS_drBL;
  
  return;
}

/******************************************************************************
  dxc_dxs_ks_calc():
  ----------------------
       -- calculates the transformation matrix  Lambda^\hat{a}_a  defined:

      x^\hat{a}[Cartesian]  = \Lambda^\hat{a}_a  x^a[Spherical] 

            where dxc_dxs[i][j] = \Lambda^i_j 

        for  Kerr-Schild coordinates.

 ******************************************************************************/
static void dxc_dxs_ks_calc(CCTK_REAL *x_cart, CCTK_REAL *x_spher, CCTK_REAL dxc_dxs[NDIM][NDIM] )
{
  int i, j; 
  CCTK_REAL r, th, ph; 
  CCTK_REAL sth,cth,sph,cph;

  for( i = 0 ; i < NDIM ; i++ ) {
    for( j = 0 ; j < NDIM ; j++ ) {
      dxc_dxs[j][i] = 0. ;
    }
  }
  
  r  = x_spher[RR]; 
  th = x_spher[TH];
  ph = x_spher[PH]; 

  sincos( th, &sth , &cth ); 
  sincos( ph, &sph , &cph ); 

  dxc_dxs[TT][TT] = 1.                    ;  // dt/dt
  dxc_dxs[XX][RR] = cph * sth             ;  // dx/dr
  dxc_dxs[XX][TH] = (r*cph - a*sph) * cth ;  // dx/dtheta
  dxc_dxs[XX][PH] = -(x_cart[YY] - y_cen) ;  // dx/dphi
  dxc_dxs[YY][RR] = sph * sth             ;  // dy/dr
  dxc_dxs[YY][TH] = (r*sph + a*cph) * cth ;  // dy/dtheta
  dxc_dxs[YY][PH] = x_cart[XX] - x_cen    ;  // dy/dphi
  dxc_dxs[ZZ][RR] = cth                   ;  // dz/dr
  dxc_dxs[ZZ][TH] = -r*sth                ;  // dz/dtheta
  //  dxc_dxs[ZZ][PH] = 0.                    ;  // dz/dphi
  
  return;

}

/******************************************************************************
  dxc_dxs_bl_calc():
  ----------------------
       -- calculates the transformation matrix  Lambda^\hat{a}_a  defined:

      x^\hat{a}[Cartesian]  = \Lambda^\hat{a}_a  x^a[Spherical] 

            where dxc_dxs[i][j] = \Lambda^i_j 

        for  Boyer-Lindquist coordinates.

 ******************************************************************************/
static void dxc_dxs_bl_calc(CCTK_REAL *x_cart, CCTK_REAL *x_spher, CCTK_REAL dxc_dxs[NDIM][NDIM] )
{
  int i, j; 
  CCTK_REAL r, th, ph, rterm, dr; 
  CCTK_REAL sth,cth,sph,cph;

  for( i = 0 ; i < NDIM ; i++ ) {
    for( j = 0 ; j < NDIM ; j++ ) {
      dxc_dxs[j][i] = 0. ;
    } 
  }
  
  r  = x_spher[RR]; 
  th = x_spher[TH];
  ph = x_spher[PH]; 

  sincos( th, &sth , &cth ); 
  sincos( ph, &sph , &cph ); 

  rterm = sqrt( r*r + asq );
  dr = r / rterm; 
  
  dxc_dxs[TT][TT] = 1.                    ;  // dt/dt
  dxc_dxs[XX][RR] = cph * sth * dr        ;  // dx/dr
  dxc_dxs[XX][TH] = rterm * cph * cth     ;  // dx/dtheta
  dxc_dxs[XX][PH] = -(x_cart[YY] - y_cen) ;  // dx/dphi
  dxc_dxs[YY][RR] = sph * sth * dr        ;  // dy/dr
  dxc_dxs[YY][TH] = rterm * sph * cth     ;  // dy/dtheta
  dxc_dxs[YY][PH] = x_cart[XX] - x_cen    ;  // dy/dphi
  dxc_dxs[ZZ][RR] = cth                   ;  // dz/dr
  dxc_dxs[ZZ][TH] = -r*sth                ;  // dz/dtheta
  //  dxc_dxs[ZZ][PH] = 0.                    ;  // dz/dphi
  
  return;

}

/******************************************************************************
  dxc_dxs_iso_calc():
  ----------------------
       -- calculates the transformation matrix  Lambda^\hat{a}_a  defined:

      x^\hat{a}[Cartesian]  = \Lambda^\hat{a}_a  x^a[Spherical] 

            where dxc_dxs[i][j] = \Lambda^i_j 

        for  "Isotropic" coordinates.

 ******************************************************************************/
static void dxc_dxs_iso_calc(CCTK_REAL *x_cart, CCTK_REAL *x_spher, CCTK_REAL dxc_dxs[NDIM][NDIM] )
{
  int i, j; 
  CCTK_REAL th, ph,r_iso;
  CCTK_REAL sth,cth,sph,cph;

  for( i = 0 ; i < NDIM ; i++ ) {
    for( j = 0 ; j < NDIM ; j++ ) {
      dxc_dxs[j][i] = 0. ;
    } 
  }

  /* BL spherical coordinates : */
  th = x_spher[TH];
  ph = x_spher[PH]; 

  r_iso = x_spher[TT];

  sincos( th, &sth , &cth ); 
  sincos( ph, &sph , &cph ); 

  dxc_dxs[TT][TT] = 1.                    ;  // dt/dt
  dxc_dxs[XX][RR] = cph * sth             ;  // dx/dr
  dxc_dxs[XX][TH] = r_iso * cph * cth     ;  // dx/dtheta
  dxc_dxs[XX][PH] = -(x_cart[YY] - y_cen) ;  // dx/dphi
  dxc_dxs[YY][RR] = sph * sth             ;  // dy/dr
  dxc_dxs[YY][TH] = r_iso * sph * cth     ;  // dy/dtheta
  dxc_dxs[YY][PH] = x_cart[XX] - x_cen    ;  // dy/dphi
  dxc_dxs[ZZ][RR] = cth                   ;  // dz/dr
  dxc_dxs[ZZ][TH] = -r_iso*sth            ;  // dz/dtheta
  //  dxc_dxs[ZZ][PH] = 0.                    ;  // dz/dphi

  return;

}

/******************************************************************************
  ks_cart_to_ks_spher_pos():
  ----------
   -- transforms the position in Cartesian KS coordinates to Spherical KS coordinates;
 ******************************************************************************/
static void ks_cart_to_ks_spher_pos(CCTK_REAL *x_cart, CCTK_REAL *x_spher)
{
  CCTK_REAL xx,yy,zz,r,t3;

  xx = x_cart[XX] - x_cen; 
  yy = x_cart[YY] - y_cen; 
  zz = x_cart[ZZ] - z_cen; 

  t3 = 0.5*(xx*xx + yy*yy + zz*zz - asq); 
  r = sqrt(   t3 + sqrt( t3*t3 + asq*zz*zz )  );

  x_spher[TT] = x_cart[TT];
  x_spher[RR] = r; 
  x_spher[TH] = acos(zz / r); 
  t3 = atan2( (yy*r - xx*a) , (xx*r + yy*a) ); 
  if( t3 < 0. ) {  t3 += 2.*M_PI; } 
  x_spher[PH] = t3;

  return;
}

/******************************************************************************
  bl_cart_to_bl_spher_pos():
  ----------
   -- transforms the position in Cartesian BL coordinates to Spherical BL coordinates;
 ******************************************************************************/
static void bl_cart_to_bl_spher_pos(CCTK_REAL *x_cart, CCTK_REAL *x_spher)
{
  CCTK_REAL xx,yy,zz,r,t3;

  xx = x_cart[XX] - x_cen; 
  yy = x_cart[YY] - y_cen; 
  zz = x_cart[ZZ] - z_cen; 

  t3 = 0.5*(xx*xx + yy*yy + zz*zz - asq); 
  r = sqrt(   t3 + sqrt( t3*t3 + asq*zz*zz )  );

  x_spher[TT] = x_cart[TT];
  x_spher[RR] = r; 
  x_spher[TH] = acos(zz / r); 
  t3 = atan2( yy , xx ); 
  if( t3 < 0. ) {  t3 += 2.*M_PI; } 
  x_spher[PH] = t3;

  return;
}

/******************************************************************************
  iso_cart_to_bl_spher_pos():
  ----------
   -- transforms the position in Cartesian "Isotropic" coordinates to Spherical BL coordinates;
   -- r^2  =  x^2 + y^2 + z^2 in these coordinates, so they are slightly distorted from flatspace
 ******************************************************************************/
static void iso_cart_to_bl_spher_pos(CCTK_REAL *x_cart, CCTK_REAL *x_spher)
{
  CCTK_REAL xx,yy,zz,riso,r,t3;

  xx = x_cart[XX] - x_cen; 
  yy = x_cart[YY] - y_cen; 
  zz = x_cart[ZZ] - z_cen; 
 
  riso = sqrt(xx*xx + yy*yy + zz*zz);
  r = 0.25 * ( 2.*riso + M + a ) * ( 2.*riso + M - a ) / riso ; 

  x_spher[TT] = riso;
  x_spher[RR] = r; 
  x_spher[TH] = acos(zz / riso); 
  t3 = atan2( yy , xx ); 
  if( t3 < 0. ) {  t3 += 2.*M_PI; } 
  x_spher[PH] = t3;

  return;
}

/****************************************************************************
  setutcon():
 ------------
     -- find the contravariant time-component of a time-like vector 
        pointing forward in time;
****************************************************************************/
static void setutcon(CCTK_REAL *vcon, CCTK_REAL gcov[][NDIM])
{
  CCTK_REAL d,b,c;
  
  d=gcov[TT][TT];

  b = gcov[TT][1]*vcon[1] + gcov[TT][2]*vcon[2] + gcov[TT][3]*vcon[3] ;

  c = gcov[1][1] * vcon[1] * vcon[1] 
    + gcov[2][2] * vcon[2] * vcon[2] 
    + gcov[3][3] * vcon[3] * vcon[3] 
    + 2.*(   gcov[1][2] * vcon[1] * vcon[2] 
    + gcov[1][3] * vcon[1] * vcon[3] 
           + gcov[2][3] * vcon[2] * vcon[3] );

  c += 1. ;  /* vector is timelike */

  vcon[0]=(-b-sqrt(b*b-d*c))/(d);   /* sign for pointing forward in time */

  return;
}

/****************************************************************************
  bl_gcov_func():
  ---------------
     -- Covariant Kerr metric in Boyer-Lindquist coordinates. 
****************************************************************************/
static void bl_gcov_func( CCTK_REAL *x, CCTK_REAL gcov[NDIM][NDIM])
{
  int i,j ;
  CCTK_REAL sth,cth,s2,r2,DD,mu ;
  CCTK_REAL r,th;

  for( i = 0 ; i < NDIM ; i++ ) {
    for( j = 0 ; j < NDIM ; j++ ) {
      gcov[i][j] = 0. ;
    } 
  }

  r  = x[RR];
  th = x[TH];
  sincos( th, &sth , &cth );   

  s2 = sth*sth ;
  r2 = r*r ;
  DD = 1. - 2.*M/r + asq/r2 ;
  mu = 1. + asq*cth*cth/r2 ;

  gcov[TT][TT] = -(1. - 2.*M/(r*mu)) ;
  gcov[TT][3] = -2.*M*a*s2/(r*mu) ;
  gcov[3][TT] = gcov[TT][3] ;
  gcov[1][1] = mu/DD ;
  gcov[2][2] = r2*mu ;
  gcov[3][3] = r2*s2*(1. + asq/r2 + 2.*M*asq*s2/(r2*r*mu)) ;

  return;
}


/***************************************************************************

 set_bondi_parameters():
 ---------------------
   -- finds the values of the hydro. quantities  at the sonic point, which
         serves as a reference point for the conservation equations given 
         in Shapiro and Teukolsky equations (G.21,G.22).  

   -- The sonic point values are then used in find_bondi_solution() to determine
       the hydro. quantities at an arbitrary radius;

   -- the "boundary conditions" that uniquely determine the Bondi solution
       are the radius of the sonic point, "rs",  and the mass accretion rate, 
       Mdot;

   -- the Bondi solution here in is the isentropic, spherically symmetric, 
       perfect fluid solution to Einstein's equations.  That is, we only 
       assume an r-dependence, there's a in-going radial velocity only, 
       and the EOS are :  P = (G-1)*rho   and   P = K rho^G  
       where  K = const.  and  G is the adiabatic constant "gam".  

***************************************************************************/
static void set_bondi_parameters( CCTK_REAL M_in, CCTK_REAL Mdot_in,  CCTK_REAL rs_in, CCTK_REAL gam )
{

  CCTK_REAL  gtemp; 

  /* Set the solution-determining parameters:    */
  M    = M_in;
  Mdot = Mdot_in;
  Msq  = M*M;
  rs   = rs_in;
  gamma_eos = gam;

  
  /* Calculate the hydro. quantities: */
  cs_sq  =  M / ( 2.*rs - 3.*M ) ; 

  if( cs_sq > (gam - 1.) ) { 
    cs_sq = gam - 1.;
    rs = 0.5 * M * ( 3. + 1./cs_sq ) ;
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"set_bondi_parameters(): bad value of rs, need to increase it !! \n"); 
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"set_bondi_parameters(): Need to change rs !! \n"); 
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"set_bondi_parameters(): rs[old] = %28.15e    rs[new] = %28.16e  \n\n",rs_in,rs); 
  }

  cs     =  sqrt(cs_sq);
  vs_sq  =  M / ( 2. * rs ) ; 
  vs     =  sqrt(vs_sq); 
  rhos   =  Mdot / ( 4. * M_PI * vs * rs * rs ) ; 
  gtemp  =  gam - 1.;
  hs     =  1. / ( 1. - cs_sq / (gam - 1.) );
  K      = hs * cs_sq * pow( rhos, (-gtemp) ) / gam ; 
  Qdot   = hs * hs * ( 1. - 3. * vs_sq ) ;
  gamma_eos = gam;

#if( LTRACE ) 
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\n#######################################################\n");         
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"Bondi Solution Parameters1: \n");
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"------------------------- \n\n");
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"M  = %28.20e     Mdot = %28.20e     rs   = %28.20e  \n",M,Mdot,rs);
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"vs = %28.20e     cs   = %28.20e     rhos = %28.20e  \n",vs,cs,rhos);
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"hs = %28.20e     K    = %28.20e     Qdot = %28.20e   \n",hs,K,Qdot);
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"gam= %28.20e     r_sol= %28.20e       \n",gamma_eos, r_sol);
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"rs   = : %28.20e \n", rs) ;
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"urs  = : %28.20e \n", vs) ;
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"rhos = : %28.20e \n", rhos) ;
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"K    = : %28.20e \n", K) ;
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"#######################################################\n\n");
#endif

  return;
  
}

/**********************************************************************/
/************************************************************

  gnr_bondi():
  -----------
    -- should be just like the routine general_newton_raphson() in utoprim*.c 
       except the "physicality" condition is different;

    -- performs Newton-Rapshon method on an arbitrary system
        though tailored to calculate  rho  second Bondi Conservation eq. 
        by ensuring that  rho > 0    (look near "METHOD specific:")

    -- inspired in part by Num. Rec.'s routine newt();

    Arguements: 

       -- x[]   = set of independent variables to solve for;
       -- n     = number of independent variables and residuals;
       -- funcd = name of function that calculates residuals, etc.;

*****************************************************************/
static int gnr_bondi( CCTK_REAL x[], int n, 
                      void (*funcd) (CCTK_REAL [], CCTK_REAL [], CCTK_REAL [], 
                      CCTK_REAL [][NEWT_DIM_B], CCTK_REAL *, 
                      CCTK_REAL *, int) )
{
  CCTK_REAL f, df, dx[NEWT_DIM_B], resid[NEWT_DIM_B], 
    jac[NEWT_DIM_B][NEWT_DIM_B];
  CCTK_REAL errx;
  int    n_iter, id, i_extra, doing_extra;

  int   keep_iterating;


  // Initialize various parameters and variables:
  errx = 1. ; 
  df = f = 1.;
  i_extra = doing_extra = 0;

  n_iter = 0;


  /* Start the Newton-Raphson iterations : */
  keep_iterating = 1;
  while( keep_iterating ) { 

    (*funcd) (x, dx, resid, jac, &f, &df, n);  /* returns with new dx, f, df */

    errx = 0.;

    /* don't use line search : */
    for( id = 0; id < n ; id++) {
      x[id] += dx[id]  ;
    }

    /****************************************/
    /* Calculate the convergence criterion */
    /****************************************/

    /* For the new criterion, always look at relative error in indep. variable: */
    // METHOD specific:
    errx  = (x[0]==0.) ?  fabs(dx[0]) : fabs(dx[0]/x[0]);


    /****************************************/
    /* Make sure that the new x[] is physical : */
    /****************************************/
    x[0] = (x[0] == 0.) ? (SMALL_BONDI)  :  fabs(x[0]);
    

    /*****************************************************************************/
    /* If we've reached the tolerance level, then just do a few extra iterations */
    /*  before stopping                                                          */
    /*****************************************************************************/
    
    if( (fabs(errx) <= NEWT_TOL_B) && (doing_extra == 0) && (EXTRA_NEWT_ITER_B > 0) ) {
      doing_extra = 1;
    }

    if( doing_extra == 1 ) i_extra++ ;

    if( ((fabs(errx) <= NEWT_TOL_B)&&(doing_extra == 0)) || 
        (i_extra > EXTRA_NEWT_ITER_B) || (n_iter >= (MAX_NEWT_ITER_B-1)) ) {
      keep_iterating = 0;
    }

    n_iter++;

  }   // END of while(keep_iterating)


  /*  Check for bad untrapped divergences : */
  if( (finite(f)==0) || (finite(df)==0)  ) {
    return(2);
  }


  if( fabs(errx) > MIN_NEWT_TOL_B){
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"newt: errx = %28.20e \n", errx); 
    return(1);
  }
  if( (fabs(errx) <= MIN_NEWT_TOL_B) && (fabs(errx) > NEWT_TOL_B) ){
    return(0);
  }
  if( fabs(errx) <= NEWT_TOL_B ){
    return(0);
  }

  return(0);

}

/******************************************************************************/
/******************************************************************************

 bondi_resid():
 --------------
     -- routine to calculate the residual and jacobian used by 
           the Newton-Raphson routine general_newton_raphson(), which is 
           used to find X2 from theta;

***********************************************************************************/
static void bondi_resid(CCTK_REAL x[], CCTK_REAL dx[], CCTK_REAL resid[], CCTK_REAL jac[][NEWT_DIM_B], 
               CCTK_REAL *f, CCTK_REAL *df, int n )
{
  CCTK_REAL v, vp, h, hp, term;

  hp  =  K * gamma_eos * pow( x[0], (gamma_eos - 2.) );   //   dh/drho 
  h   =  1. +  hp * x[0] / ( gamma_eos - 1. ); 
  v   =  Mdot / ( 4. * M_PI * r_sol * r_sol * x[0] );    
  vp  =  -v / x[0];   //  dv/drho
  term = 1. - 2.*M/r_sol + v*v;
  resid[0]  =  -Qdot  +  h * h * term;
  jac[0][0] =  2. * h *( hp*term + h*v*vp );
  dx[0] = -resid[0] / jac[0][0];
  *f = 0.5*resid[0]*resid[0];
  *df = -2. * (*f);

  return;

}


/***************************************************************************/
/***************************************************************************

 find_bondi_solution():
 ---------------------

   -- essentially just calls gnr_bondi() to find the solution for
      the density at a given radius, given the parameters calculated from 
      set_bondi_parameters();

   -- after the density is found, the density (rho), internal energy densit (u), magnitude 
        of the radial component of the 4-velocity (v) are returned to the calling 
        routine; 

   -- requires r = radius at which we want solution

   -- note that v is a magnitude, so the user will have to set u^r = -v ;

   -- if there is an error in finding the solution, it returns the error 
       status from the root-finding routine.  See documentation of the 
       gnr_bondi() for further details;

***************************************************************************/
static int find_bondi_solution( CCTK_REAL r, CCTK_REAL *rho, CCTK_REAL *u, CCTK_REAL *v )
{

  int  retval=0;
  const int  ntries = 10000;
  int  itry;

  CCTK_REAL rhotmp, rho_guess;
  CCTK_REAL dr,ur;

  
  /************************************************************************/
  /* Find the initial guess for the newton iterations:                    */
  /* Take the sonic point values if we have no better guess (when rho<0)  */
  /************************************************************************/

  if( *rho < 0. ) {  
    if( r > 0.9*rs && r < 1.1*rs ) { 
      *rho = rhos;
    }
    else { 
      //  rhotmp = (sqrt(Qdot) - 1.) * (gamma_eos - 1.) / ( gamma_eos * K );
      //  rho_guess = pow( rhotmp , (1./(gamma_eos - 1.)) );
      if(r < rs) {  ur = pow(r,-0.5)     ;  }
      else       {  ur = 0.5*pow(r,-1.5) ;  }
      *rho = Mdot / (4.*M_PI * r * r * ur); 
    }
  }

  // safe guess value for multiple tries
  rho_guess = *rho;
  

  // set global variables needed by residual function:
  r_sol = r ; 


  // Use Newton's method to find rho:
  retval = gnr_bondi( rho, NEWT_DIM_B, bondi_resid);     


  // first try guess if failure 
  if( retval ) { 
    *rho = rho_guess;
    retval = gnr_bondi( rho, NEWT_DIM_B, bondi_resid);     
  }

  // If we were unsure about the guess and solver fails, then creep from known solution to desired point:
  if( retval ) { 

    dr = (r - rs)/(1.*(ntries-1));
    
    *rho = rhos;   // start with sonic point value and near sonic point

    // go gradually away from sonic point toward location where we want the solution:
    r_sol = rs ;
    for( itry = 1; itry < ntries; itry++ ) { 
      r_sol  += dr;

      retval = gnr_bondi( rho, NEWT_DIM_B, bondi_resid);     

      if( retval ) { 
        CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"find_bondi_solution: Incr. guess failed, decrease dfactor, retval = %d, r = %g, itry = %d \n", retval, r, itry);
        return(10);
      }
    }
    
    // No try where we want the solution:
    r_sol = r ; 
    retval = gnr_bondi( rho, NEWT_DIM_B, bondi_resid );  

    if( retval ) { 
      CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"find_bondi_solution: Final Incr. guess failed, decrease dfactor??, retval = %d \n", retval);
      return(11);
    }

  }

  rhotmp = *rho;

  // Calculate other quantities:
  *u = K * pow( rhotmp, gamma_eos ) / (gamma_eos - 1.);

  *v = Mdot / ( 4. * M_PI * r * r * rhotmp );

  if( *u <= 0. ) { retval = -1; } 

  return( retval ) ;

}  

/***********************************************************************************/
/***********************************************************************************
  calc_vel_bondi():
  ---------
   -- calculates the 4-velocity from the amplitude of the 
        radial component of the 4-velocity in Boyer-Lindquist coordinates.  

***********************************************************************************/
static void  calc_vel_bondi( CCTK_REAL vtmp, CCTK_REAL x[NDIM], CCTK_REAL x_spher[NDIM],  CCTK_REAL ucon[NDIM] )
{
  int i,j;
  CCTK_REAL  ucon_bl[NDIM] = {0.};
  CCTK_REAL  ucon_ks[NDIM];
  CCTK_REAL  gcov[NDIM][NDIM];
  CCTK_REAL  r_iso;
  CCTK_REAL dxc_dxs[NDIM][NDIM];

  ucon_bl[RR] = -vtmp;

  /* Find time component of 4-velocity: */
  bl_gcov_func( x_spher, gcov );      
  setutcon( ucon_bl, gcov );


  switch( coord_type ) {
  
  case COORD_BOYERLINDQUIST :
    dxc_dxs_bl_calc(x, x_spher, dxc_dxs );
    DLOOP1 { ucon[i] = 0.; } 
    DLOOP2 { ucon[i] += dxc_dxs[i][j] * ucon_bl[j] ; }
    break;


  case COORD_KERRSCHILD    :
    bl_to_ks_con(x_spher,ucon_bl,ucon_ks); 
    dxc_dxs_ks_calc(x, x_spher, dxc_dxs );
    DLOOP1 { ucon[i] = 0.; } 
    DLOOP2 { ucon[i] += dxc_dxs[i][j] * ucon_ks[j] ; }
    break;


  case COORD_ISOTROPIC     :
    r_iso = x_spher[TT]; 
    ucon_bl[RR] /=  1. + 0.25 * (asq-Msq) / (r_iso*r_iso)  ;    /* BL to Isotropic coordinate transformation */
    /* I believe we can use BL's cartesian transformation, while using BL's radius : */
    dxc_dxs_iso_calc(x, x_spher, dxc_dxs );
    DLOOP1 { ucon[i] = 0.; } 
    DLOOP2 { ucon[i] += dxc_dxs[i][j] * ucon_bl[j] ; }
    break; 

  default:
    assert(0 && "Internal error");
    return; /* NOTREACHED */

  }
  
  return;
}

/***********************************************************************************/
/***********************************************************************************
  GRHydro_Bondi(): 
  ---------
   -- driver routine for the Bondi solution;

***********************************************************************************/
void GRHydro_Bondi(CCTK_ARGUMENTS)
{
  DECLARE_CCTK_ARGUMENTS;
  DECLARE_CCTK_PARAMETERS;
  CCTK_REAL det;
  CCTK_REAL rhotmp, utmp, vtmp, rspher, xpos[NDIM], x_spher[NDIM], ucon[NDIM];
  int retval;
  CCTK_REAL  *r_bondi, *logr_bondi, *rho_bondi, *u_bondi, *v_bondi;
  CCTK_INT   *bad_bondi;
  CCTK_REAL  dlogr,logrmin;
  CCTK_REAL  rmin_bondi,rmax_bondi;
//  CCTK_INT GRHydro_reflevel=0;

  CCTK_INT nbondi; 
  CCTK_INT ileft, iright, nans_exist;
  CCTK_REAL sigma;
  
  
  const int size = cctk_lsh[0] * cctk_lsh[1] * cctk_lsh[2];
  int i, imin, j;

#    define velx(i_)  vel[i_ + 0*size]
#    define vely(i_)  vel[i_ + 1*size]
#    define velz(i_)  vel[i_ + 2*size]
#    define   sx(i_) scon[i_ + 0*size]
#    define   sy(i_) scon[i_ + 1*size]
#    define   sz(i_) scon[i_ + 2*size]

  if( CCTK_EQUALS(bondi_coordinates,"Boyer-Lindquist") ) { 
    coord_type = COORD_BOYERLINDQUIST ;
  }
  if( CCTK_EQUALS(bondi_coordinates,"Kerr-Schild") ) { 
    coord_type = COORD_KERRSCHILD  ;
  }
  if( CCTK_EQUALS(bondi_coordinates,"Isotropic") ) { 
    coord_type = COORD_ISOTROPIC ;
  }

  /* xyz location of the black hole : */
  i = 0; 
  x_cen = bh_bondi_pos_x[i] ; 
  y_cen = bh_bondi_pos_y[i] ; 
  z_cen = bh_bondi_pos_z[i] ; 

  M      = bondi_central_mass[i];
  a      = M*bondi_central_spin[i];
  asq    = a * a; 
  rmin_bondi = M * bondi_rmin[i];
  rmax_bondi = M * bondi_rmax[i];

  nbondi = n_bondi_pts[i];

  set_bondi_parameters( M, mdot_sonicpt_bondi, r_sonicpt_bondi, gl_gamma);


#if(LTRACE)
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\n##################################################\n");                       
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"  Geometry PARAMETERS \n------------------------------------\n");		  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  M           =  %28.18e \n",M       ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  a           =  %28.18e \n",a       ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  x_cen       =  %28.18e \n",x_cen   ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  y_cen       =  %28.18e \n",y_cen   ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  z_cen       =  %28.18e \n",z_cen   ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  rmin_bondi  =  %28.18e \n",rmin_bondi   ); 				  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  rmax_bondi  =  %28.18e \n",rmax_bondi   ); 				  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  nbondi      =  %d      \n",(int)nbondi  ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\n------------------------------------\n");					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"   SOLUTION PARAMETERS \n------------------------------------\n");		  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  bondi_coordinates          =  %s      \n",bondi_coordinates ); 		  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  mdot_sonicpt_bondi         =  %28.18e \n",mdot_sonicpt_bondi); 		  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  r_sonicpt_bondi            =  %28.18e \n",r_sonicpt_bondi   ); 		  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  gl_gamma    =  %28.18e \n",gl_gamma     ); 	  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\n------------------------------------\n");					  
#endif

  if( r_sonicpt_bondi < rmin_bondi ) { 
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"sonic point lies below solution domain!!");
  }

  if( r_sonicpt_bondi > rmax_bondi ) { 
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"sonic point lies beyond solution domain!!");
  }


  /*********************************************************************************
     ARRAY ALLOCATIONS :
  *********************************************************************************/
  /* global solution : */
  if( (r_bondi = (CCTK_REAL *) calloc(nbondi, sizeof(CCTK_REAL))) == NULL ) { 
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc r_bondi \n");
    return;
  }
  if( (logr_bondi = (CCTK_REAL *) calloc(nbondi, sizeof(CCTK_REAL))) == NULL ) { 
    free(r_bondi);    
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc logr_bondi \n");
    return;
  }
  if( (rho_bondi = (CCTK_REAL *) calloc(nbondi, sizeof(CCTK_REAL))) == NULL ) { 
    free(r_bondi);    free(logr_bondi);
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc rho_bondi \n");
    return;
  }
  if( (u_bondi = (CCTK_REAL *) calloc(nbondi, sizeof(CCTK_REAL))) == NULL ) { 
    free(r_bondi);    free(logr_bondi);    free(rho_bondi);
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc u_bondi \n");
    return;
  }
  if( (v_bondi = (CCTK_REAL *) calloc(nbondi, sizeof(CCTK_REAL))) == NULL ) { 
    free(r_bondi);    free(logr_bondi);    free(rho_bondi);    free(u_bondi);
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc v_bondi \n");
    return;
  }
  if( (bad_bondi = (CCTK_INT *) calloc(nbondi, sizeof(CCTK_INT))) == NULL ) { 
    free(r_bondi);    free(logr_bondi);    free(rho_bondi);    free(u_bondi); free(v_bondi);
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc bad_bondi \n");
    return;
  }
  

  /*********************************************************************************
     SOLUTION DOMAIN :
  *********************************************************************************/
  logrmin = log10(rmin_bondi);
  dlogr = (log10(rmax_bondi) - logrmin)/(1.*(nbondi-1));

  for(i=0; i < nbondi; i++) {   
    logr_bondi[i] = logrmin + dlogr*i;   
  }

  for(i=0; i < nbondi; i++) {   
    r_bondi[i] = pow(10.,logr_bondi[i]);
  }

  rhotmp = 1.e200; 
  imin = 0; 

  /* find the position in the array where the sonic point lies */
  for(i=0; i < nbondi; i++) {
    utmp = fabs(r_bondi[i] - r_sonicpt_bondi); 
    if( utmp < rhotmp ) { 
      rhotmp = utmp; 
      imin = i ; 
    }
  }

  /*********************************************************************************
     DETERMINE BONDI SOLUTION :
  *********************************************************************************/

  /* start at the sonic point (where we know the solution) and spread out from there using the 
     adjacent point as the guess for the next furthest point : */
  rhotmp = -1.;  // start with guess

  for(i=imin; i < nbondi; i++) {
    rspher = r_bondi[i]; 
    retval = find_bondi_solution( rspher, &rhotmp, &utmp, &vtmp );
    if( retval ) { 
      CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"Problem1 with find_bondi_solution() at  i = %d,  r = %28.16e \n",i,rspher);
      rhotmp = -1. ;      vtmp = 0.;       /* trigger the floor and set to staticity  */
    }
    if(rhotmp < initial_rho_abs_min)  {
      rhotmp = initial_rho_abs_min;
      utmp = K * pow( rhotmp, gl_gamma ) / (gl_gamma - 1.);
    }
    rho_bondi[i] = rhotmp;    u_bondi[i]   = utmp;     v_bondi[i]   = vtmp; 
  }

  rhotmp = -1.;  // start with guess

  for(i=imin-1; i >= 0; i--) {
    rspher = r_bondi[i]; 
    retval = find_bondi_solution( rspher, &rhotmp, &utmp, &vtmp );
    if( retval ) { 
      CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"Problem2 with find_bondi_solution() at  i = %d,  r = %28.16e \n",i,rspher);
      rhotmp = -1. ;      vtmp = 0.;       /* trigger the floor and set to staticity  */
    }
    if(rhotmp < initial_rho_abs_min)  {
      rhotmp = initial_rho_abs_min;
      utmp = K * pow( rhotmp, gl_gamma ) / (gl_gamma - 1.);
    }
    rho_bondi[i] = rhotmp;    u_bondi[i]   = utmp;     v_bondi[i]   = vtmp; 
  }


  /* Verify Bondi solution, extrapolate/interpolate over Nans */ 
  nans_exist = 0 ; 

  for(i=0; i < nbondi; i++) {   bad_bondi[i] = 0 ; } 
  for(i=0; i < nbondi; i++) {     
    if( (!finite(rho_bondi[i])) || (!finite(u_bondi[i])) || (!finite(v_bondi[i])) || (rho_bondi[i]==0.) || (v_bondi[i]==0.) || (u_bondi[i]==0.) ) {   
      bad_bondi[i] = 1 ; 
      nans_exist++; 
    }
  }

  if( nans_exist > (nbondi-3) ) { 
    CCTK_VWarn(CCTK_WARN_ABORT, __LINE__, __FILE__, CCTK_THORNSTRING,"Too many bad points %12d out of  %12d  \n",(int)nans_exist,(int)nbondi); 
  }

  /* We find the 2-point stencil by favoring interpolation over extrapolation, no matter the distance between the points */
  if( nans_exist ) { 
    for(i=0; i < nbondi; i++) { 
      if( bad_bondi[i] ) { 
	j = i-1;
	while( (j > 0) && (bad_bondi[j]) ) { j--; }

	if( (j==0) && bad_bondi[j] ) { 
	  /* No good points to the left, need two points on the right: */

	  while( (j < (nbondi-1)) && (bad_bondi[j]) ) { j++; }
	  if( (j==(nbondi-1)) && bad_bondi[j] ) { 
	    CCTK_WARN(CCTK_WARN_ABORT,"No available points with which to interpolate!\n");
            ileft = 0; /* NOTREACED */
            iright = 0; /* NOTREACHED */
	  }
	  else { 
	    ileft = j ; 

	    /* Continue searching to the right: */
	    j++; 
	    while( (j < (nbondi-1)) && (bad_bondi[j]) ) { j++; }
	    if( (j==(nbondi-1)) && bad_bondi[j] ) { 
	      CCTK_WARN(CCTK_WARN_ABORT,"Need another point to the right but cannot find one! \n");
              iright = 0; /* NOTREACHED */
	    }
	    else { 
	      iright = j ; 
	    }
	  }
	}
	else { 
	  /* Found a left point, need a right: */
	  ileft = j ; 

	  j = i+1;
	  while( (j < (nbondi-1)) && (bad_bondi[j]) ) { j++; }
	  if( (j==(nbondi-1)) && bad_bondi[j] ) { 
	    /* No good points to the right, need to find another point on the left: */
	    iright = ileft; 
	    
	    j = ileft-1; 
	    while( (j > 0) && (bad_bondi[j]) ) { j--; }
	    if( (j==0) && bad_bondi[j] ) { 
	      CCTK_WARN(CCTK_WARN_ABORT,"Need another point to the left but cannot find one! \n");
              ileft = 0; /* NOTREACED */
	    }
	    else {
	      ileft = j;
	    }
	  }
	  else { 
	    iright = j;
	  }
	}
	/* Now interpolate over the bad point with the good points found: */ 
	
	sigma = (r_bondi[i]-r_bondi[ileft])/(r_bondi[iright]-r_bondi[ileft]); 
	rho_bondi[i] = rho_bondi[iright] * sigma   +  rho_bondi[ileft] * (1.-sigma) ;
	  u_bondi[i] =   u_bondi[iright] * sigma   +    u_bondi[ileft] * (1.-sigma) ;
	  v_bondi[i] =   v_bondi[iright] * sigma   +    v_bondi[ileft] * (1.-sigma) ;
      }
    }
  }
    
  

#if(LTRACE) 
  for(i=0; i < nbondi; i++) {  
    CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"radial-bondisoln %12d %26.16e %26.16e %26.16e %26.16e \n",i,r_bondi[i],rho_bondi[i],u_bondi[i],v_bondi[i]);  
  }
#endif

  /*********************************************************************************
     LOAD GRID FUNCTIONS WITH THE SOLUTION
  *********************************************************************************/
  xpos[TT] = 0.;
  
  for(i=0; i < size; i++) {

    xpos[XX] = x[i] ;
    xpos[YY] = y[i] ;
    xpos[ZZ] = z[i] ;


    switch( coord_type ) {
  
    case COORD_BOYERLINDQUIST :
      bl_cart_to_bl_spher_pos( xpos, x_spher);
      break;

    case COORD_KERRSCHILD    :
      ks_cart_to_ks_spher_pos( xpos, x_spher);
      break;

    case COORD_ISOTROPIC     :
      iso_cart_to_bl_spher_pos(xpos, x_spher); 
      break; 

    default:
      assert(0 && "Internal error");
      return; /* NOTREACHED */

    }

    rspher = x_spher[RR]; 

    if( rspher < rmin_bondi )  rspher = rmin_bondi;
    

    /* Find nearest point in the Bondi solution : */
    j = (int)  ( 0.5 +  (log10(rspher) - logrmin) / dlogr ) ; 

    if(  j < 0  ) { 
      CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"Grid point resides outside solution domain:  %26.16e %26.16e %26.16e %26.16e %26.16e\n", rspher, rmin_bondi, xpos[XX],xpos[YY],xpos[ZZ]); 
      j = 0; 
    }
    else if( j > (nbondi - 1) ) {
      CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"GRHydro_Bondi::  Grid point resides outside solution domain:  %26.16e %26.16e %26.16e %26.16e %26.16e\n", rspher, rmin_bondi, xpos[XX],xpos[YY],xpos[ZZ]); 
      j = nbondi - 1; 
    }

    rhotmp = rho_bondi[j];
    retval = find_bondi_solution( rspher, &rhotmp, &utmp, &vtmp );
    if( retval ) { 
      CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"Problem3 with find_bondi_solution() at  i = %d,  r = %28.16e \n",i,rspher);
      rhotmp = -1. ;      vtmp = 0.;       /* trigger the floor and set to staticity  */
    }

    if(rhotmp < initial_rho_abs_min)  {
      rhotmp = initial_rho_abs_min;
      utmp = K * pow( rhotmp, gl_gamma ) / (gl_gamma - 1.);
    }

    rho[i] = rhotmp;
    eps[i] = utmp/rhotmp;
    calc_vel_bondi(vtmp, xpos, x_spher, ucon);

    det = 1./alp[i];   /* temp var */

    velx(i) = (ucon[XX]/ucon[TT] + betax[i]) * det;
    vely(i) = (ucon[YY]/ucon[TT] + betay[i]) * det;
    velz(i) = (ucon[ZZ]/ucon[TT] + betaz[i]) * det;


    SpatialDet(gxx[i],gxy[i],gxz[i],gyy[i],gyz[i],gzz[i],&det);

      Prim2ConGen(*GRHydro_eos_handle,gxx[i],gxy[i],
		  gxz[i],gyy[i],gyz[i],gzz[i],
		  det, &dens[i],&sx(i),&sy(i),&sz(i),
		  &tau[i],rho[i],
		  velx(i),vely(i),velz(i),
		  eps[i],&press[i],&w_lorentz[i]);

      if( (!finite(dens[i])) || (!finite(sx(i))) || (!finite(sy(i))) || (sz(i)==0.) || (tau[i]==0.) || (press[i]==0.) || (w_lorentz[i]==0.) ) {
	CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"bad point at %12d  :  %26.16e  %26.16e  %26.16e  %26.16e  %26.16e  %26.16e  %26.16e  %26.16e  %26.16e  %26.16e  %26.16e  \n",i,rspher, rho[i], eps[i], press[i], velx(i), vely(i), velz(i), dens[i], sx(i), sy(i), sz(i) ); 
	dens[i] = rho_bondi[0];
	tau[i]  =   u_bondi[0];
	press[i] = (gamma_eos-1.)*u_bondi[0];
	w_lorentz[i]  = 1.;
	sx(i) = 0.;	sy(i) = 0.;	sz(i) = 0.;
      }

  }

  free(r_bondi);      free(logr_bondi);      free(rho_bondi);     free(u_bondi);   free(v_bondi);


#    undef velx
#    undef vely
#    undef velz
#    undef sx
#    undef sy
#    undef sz


  return;
}




#undef LTRACE 
#undef NEWT_DIM_B        
#undef MAX_NEWT_ITER_B   
#undef NEWT_TOL_B        
#undef MIN_NEWT_TOL_B    
#undef EXTRA_NEWT_ITER_B 
#undef SMALL_BONDI 
#undef NDIM 
#undef TT
#undef RR
#undef TH
#undef PH
#undef XX
#undef YY
#undef ZZ
#undef COORD_BOYERLINDQUIST
#undef COORD_KERRSCHILD    
#undef COORD_ISOTROPIC     
#undef DLOOP1
#undef DLOOP2

#ifdef LOCAL_SINCOS
# undef sincos
# undef LOCAL_SINCOS
#endif

```

GRHydro_Con2Prim.F90:
```
 /*@@
   @file      GRHydro_Con2Prim.F90
   @date      Sat Jan 26 02:49:32 2002
   @author    Luca Baiotti
   @desc 
   A test of the conservative to primitive exchange.
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"

 /*@@
   @routine    GRHydro_con2primtest
   @date       Sat Jan 26 02:49:58 2002
   @author     Luca Baiotti
   @desc 
   A test of the conservative to primitive variable solver.
   @enddesc 
   @calls     
   @calledby   
   @history 
 
   @endhistory 

@@*/

subroutine GRHydro_Init_Data_RefinementLevel(CCTK_ARGUMENTS)

  implicit none
  DECLARE_CCTK_ARGUMENTS

  GRHydro_init_data_reflevel = aint(log10(dble(cctk_levfac(1)))/log10(2.0d0))

end subroutine GRHydro_Init_Data_RefinementLevel


subroutine GRHydro_con2primtest(CCTK_ARGUMENTS)
  
  implicit  none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS

  integer didit,i,j,k,nx,ny,nz
  CCTK_REAL det,uxx,uxy,uxz,uyy,uyz,uzz
  CCTK_REAL dens_send,sx_send,sy_send,sz_send,tau_send
  CCTK_REAL rho_send,velx_send,vely_send,velz_send,eps_send
  CCTK_REAL press_send,w_lorentz_send,x_send,y_send,z_send,r_send
  CCTK_REAL pmin, epsmin
  CCTK_REAL C2P_failed
  logical epsnegative

! begin EOS Omni vars
  integer :: n = 1
  integer :: keytemp = 0
  integer :: anyerr = 0
  integer :: keyerr(1) = 0
  real*8  :: xpress = 0.0d0
  real*8  :: xeps = 0.0d0
  real*8  :: xtemp = 0.0d0
  real*8  :: xye = 0.0d0
! end EOS Omni vars

  call CCTK_WARN(1,"For this test, remember to use a polytropic EoS and to set eos_gamma = 2.0 and eos_k = 100.0")

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)
  
  x_send = 0.0d0
  y_send = 0.0d0
  z_send = 0.0d0
  r_send = 0.0d0
  
  det = 1.0d0
  uxx = 1.0d0
  uyy = 1.0d0 
  uzz = 1.0d0
  uxy = 0.0d0
  uxz = 0.0d0
  uyz = 0.0d0
  
  dens_send = 1.29047362d0
  sx_send   = 0.166666658d0
  sy_send   = 0.166666658d0
  sz_send   = 0.166666658d0
  tau_send  = 0.484123939d0
  
  rho_send = 1.0d0
  velx_send = 0.0d0
  vely_send = 0.0d0
  velz_send = 0.0d0
  eps_send = 1.0d-6
  press_send = 6.666666666666667d-7
  w_lorentz_send = 1.0d0

  epsnegative = .false.

  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       GRHydro_rho_min,xeps,xtemp,xye,pmin,keyerr,anyerr)

  call EOS_Omni_EpsFromPress(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       GRHydro_rho_min,xeps,xtemp,xye,pmin,epsmin,keyerr,anyerr)

  C2P_failed = 0.d0

  write(*,*) 'Con2Prim test: converting to primitive variables'
  call Con2Prim_pt(GRHydro_eos_handle,dens_send,sx_send,sy_send,sz_send,&
       tau_send,rho_send,velx_send,vely_send,velz_send,&
       eps_send,press_send,w_lorentz_send, &
       uxx,uxy,uxz,uyy,uyz,uzz,det,x_send,y_send,z_send,r_send,&
       epsnegative,GRHydro_rho_min, pmin, epsmin, GRHydro_init_data_reflevel, C2P_failed)
  write(*,*) 'Con2Prim test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   press : ',press_send
  write(*,*) '   w_lor : ',w_lorentz_send
  
  STOP

  return

end subroutine GRHydro_con2primtest

```

GRHydro_Macros.h:
```
#define SPATIAL_DETERMINANT(gxx_,gxy_,gxz_,gyy_,gyz_,gzz_) \
  (-(gxz_)**2*(gyy_) + 2*(gxy_)*(gxz_)*(gyz_) - (gxx_)*(gyz_)**2 - (gxy_)**2*(gzz_) \
   + (gxx_)*(gyy_)*(gzz_))

#define DOTP(gxx_,gxy_,gxz_,gyy_,gyz_,gzz_,x1_,y1_,z1_,x2_,y2_,z2_) \
 ( (gxx_)*(x1_)*(x2_)+(gyy_)*(y1_)*(y2_)+(gzz_)*(z1_)*(z2_)+ \
   (gxy_)*( (x1_)*(y2_)+(y1_)*(x2_) )+(gxz_)*( (x1_)*(z2_)+(z1_)*(x2_) )+\
   (gyz_)*( (y1_)*(z2_)+(z1_)*(y2_) ) )

#define DOTP2(gxx_,gxy_,gxz_,gyy_,gyz_,gzz_,x_,y_,z_)	\
 ( (gxx_)*(x_)**2+(gyy_)*(y_)**2+(gzz_)*(z_)**2+ \
  2.0*( (gxy_)*(x_)*(y_)+(gxz_)*(x_)*(z_)+(gyz_)*(y_)*(z_) ) )

```

GRHydro_P2C2PM_polytype.F90:
```
 /*@@
   @file      GRHydro_P2C2PM_polytype.F90
   @date      Sep 25, 2010
   @author    Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   A test of the conservative <--> primitive variable exchange
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"

 /*@@
   @routine    p2c2pm
   @date       Sep 25, 2010
   @author     Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   Testing the conservative <--> primitive variable transformations.
   The values before and after should match.
   @enddesc 
   @calls     
   @calledby   
   @history 
 
   @endhistory 

@@*/

subroutine p2c2pm_polytype(CCTK_ARGUMENTS)

  implicit none

  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS

  integer didit,i,j,k,nx,ny,nz
  CCTK_REAL det, local_K
  CCTK_REAL uxx,uxy,uxz,uyy,uyz,uzz
  CCTK_REAL gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send
  CCTK_REAL dens_send,sx_send,sy_send,sz_send,tau_send
  CCTK_REAL bconsx_send,bconsy_send,bconsz_send
  CCTK_REAL rho_send,velx_send,vely_send,velz_send,eps_send
  CCTK_REAL press_send,w_lorentz_send,x_send,y_send,z_send,r_send
  CCTK_REAL bvcx_send,bvcy_send,bvcz_send,b2_send
  CCTK_REAL pmin, epsmin, local_gam, sc_send
  CCTK_INT C2P_failed
  logical epsnegative

! begin EOS Omni vars
  integer :: n = 1
  integer :: keytemp = 0
  integer :: anyerr = 0
  integer :: keyerr(1) = 0
  real*8  :: xpress = 0.0d0
  real*8  :: xeps = 0.0d0
  real*8  :: xtemp = 0.0d0
  real*8  :: xye = 0.0d0
! end EOS Omni vars

  call CCTK_WARN(1,"This test works only with Ideal_Fluid EoS")

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)
  
  x_send = 0.0d0
  y_send = 0.0d0
  z_send = 0.0d0
  r_send = 0.0d0
  
  gxx_send = 1.0d0
  gyy_send = 1.0d0 
  gzz_send = 1.0d0
  gxy_send = 0.0d0
  gxz_send = 0.0d0
  gyz_send = 0.0d0
  
  det = 1.0d0
  
  uxx = 1.0d0
  uyy = 1.0d0 
  uzz = 1.0d0
  uxy = 0.0d0
  uxz = 0.0d0
  uyz = 0.0d0
  
  rho_send = 1.29047362d0
  velx_send   = 0.166666658d0
  vely_send   = 0.166666658d0
  velz_send   = 0.166666658d0
!!$  eps_send  = 0.484123939d0
  
  bvcx_send   = Bx_init
  bvcy_send   = By_init
  bvcz_send   = Bz_init
  bconsx_send   = Bx_init
  bconsy_send   = By_init
  bconsz_send   = Bz_init

  w_lorentz_send = 1.d0/sqrt(1.0d0-velx_send*velx_send-vely_send*vely_send-velz_send*velz_send)

  epsnegative = .false.
  
  GRHydro_rho_min = 1.e-10

  call EOS_Omni_press(GRHydro_polytrope_handle,keytemp,GRHydro_eos_rf_prec,n,&
       rho_send,1.0d0,xtemp,xye,press_send,keyerr,anyerr)
  call EOS_Omni_press(GRHydro_polytrope_handle,keytemp,GRHydro_eos_rf_prec,n,&
       GRHydro_rho_min,1.0d0,xtemp,xye,pmin,keyerr,anyerr)

  call EOS_Omni_EpsFromPress(GRHydro_polytrope_handle,keytemp,GRHydro_eos_rf_prec,n,&
       rho_send,xeps,xtemp,xye,press_send,eps_send,keyerr,anyerr)
  call EOS_Omni_EpsFromPress(GRHydro_polytrope_handle,keytemp,GRHydro_eos_rf_prec,n,&
       GRHydro_rho_min,xeps,xtemp,xye,pmin,epsmin,keyerr,anyerr)

  call EOS_Omni_press(GRHydro_polytrope_handle,keytemp,GRHydro_eos_rf_prec,n,&
       1.d0,1.d0,xtemp,xye,xpress,keyerr,anyerr)
  local_K = xpress

  local_gam=log(press_send/local_K)/log(rho_send)

  C2P_failed = 0

  write(*,*) 'P2C2PM test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   W     : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  write(*,*) 'P2C2PM test: converting back to conserved variables.'
  call prim2conpolytypeM(GRHydro_polytrope_handle,gxx_send, gxy_send, gxz_send, gyy_send, gyz_send, gzz_send, det, &
       dens_send, sx_send, sy_send, sz_send, tau_send, bconsx_send, bconsy_send, bconsz_send, rho_send, &
       velx_send, vely_send, velz_send, eps_send, press_send, bvcx_send, bvcy_send, bvcz_send, w_lorentz_send) 

  write(*,*) 'P2C2PM test: initial values.'
  write(*,*) '   conservative variables: '
  write(*,*) '   dens: ',dens_send
  write(*,*) '   sx  : ',sx_send
  write(*,*) '   sy  : ',sy_send
  write(*,*) '   sz  : ',sz_send
  write(*,*) '   tau : ',tau_send
  write(*,*) '   Bconsx  : ',bconsx_send
  write(*,*) '   Bconsy  : ',bconsy_send
  write(*,*) '   Bconsz  : ',bconsz_send
  write(*,*) '   eps : ',eps_send
  write(*,*) '   W   : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send

  write(6,*)'local_K:',local_K
  sc_send=local_K*dens_send

  write(*,*) 'P2C2PM test: getting the associated primitive variables.'
  call GRHydro_Con2PrimM_Polytype_pt(GRHydro_polytrope_handle,local_gam,dens_send,sx_send,sy_send,sz_send, &
       sc_send,bconsx_send,bconsy_send,bconsz_send,rho_send,velx_send,vely_send,velz_send, &
       eps_send,press_send,bvcx_send,bvcy_send,bvcz_send,b2_send,w_lorentz_send, &
       gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,&
       uxx,uxy,uxz,uyy,uyz,uzz,det,&
       epsnegative,C2P_failed)
  
  write(*,*) 'P2C2PM test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   W     : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  STOP

  return

end subroutine p2c2pm_polytype

```

CheckParam.c:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Parameters.h"

void GRHydro_InitData_CheckParameters(CCTK_ARGUMENTS)
{
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS

  if (timelevels < 2)
  {
      CCTK_PARAMWARN("You have to set 'HydroBase::timelevels to at least 2");
  }

  if(CCTK_Equals(Bvec_evolution_method,"GRHydro") && 
     ((CCTK_Equals(initial_hydro,"ony_atmo")) ||
      (CCTK_Equals(initial_hydro,"read_conformal")) ||
      (CCTK_Equals(initial_hydro,"simple_wave")) ||
      (CCTK_Equals(initial_data,"con2primtest")) ||
      (CCTK_Equals(initial_data,"reconstruction_test")) ||
      (CCTK_Equals(shocktube_type,"sphere")))) 
    {
      CCTK_PARAMWARN("That test not yet implemented in MHD!");
    }

  if(!CCTK_Equals(Bvec_evolution_method,"GRHydro") && 
     ((CCTK_Equals(shock_case,"Balsara0"   )) ||
      (CCTK_Equals(shock_case,"Balsara1"   )) ||
      (CCTK_Equals(shock_case,"Balsara2"   )) ||
      (CCTK_Equals(shock_case,"Balsara3"   )) ||
      (CCTK_Equals(shock_case,"Balsara4"   )) ||
      (CCTK_Equals(shock_case,"Balsara5"   )) ||
      (CCTK_Equals(shock_case,"Alfven"     )) ||
      (CCTK_Equals(shock_case,"Komissarov1")) ||
      (CCTK_Equals(shock_case,"Komissarov2")) ||
      (CCTK_Equals(shock_case,"Komissarov3")) ||
      (CCTK_Equals(shock_case,"Komissarov4")) ||
      (CCTK_Equals(shock_case,"Komissarov5")) ||
      (CCTK_Equals(shock_case,"Komissarov6")) ||
      (CCTK_Equals(shock_case,"Komissarov7")) ||
      (CCTK_Equals(shock_case,"Komissarov8")) ||
      (CCTK_Equals(shock_case,"Komissarov9")) ||
      (CCTK_Equals(initial_hydro,"cylexp")) 
      ))
    {
      CCTK_PARAMWARN("That test requires MHD!  Set Bvec_evolution_method=GRHYDRO!");
    }

  /* Checks for Bondi solution initial data : */
  if(CCTK_Equals(Bvec_evolution_method,"GRHydro") && 
     CCTK_Equals(initial_hydro,"hydro_bondi_solution") )
    {
      CCTK_PARAMWARN("Please set initial_hydro='magnetized_bondi_solution' instead to initialize the magnetic field correctly!");
    }

  if(!CCTK_Equals(Bvec_evolution_method,"GRHydro") && 
     CCTK_Equals(initial_hydro,"magnetized_bondi_solution") )
    {
      CCTK_PARAMWARN("Please set initial_hydro='hydro_bondi_solution' instead to NOT initialize the magnetic field!");
    }

  if((CCTK_Equals(initial_hydro,"magnetized_bondi_solution") || CCTK_Equals(initial_hydro,"magnetized_bondi_solution_iso")) &&
     !CCTK_Equals(initial_Bvec, "magnetized Bondi") )
    {
      CCTK_PARAMWARN("Please set initial_Bvec='magnetized Bondi' to properly initialize the magnetic field for Bondi solutions!");
    }

  if( CCTK_Equals(initial_hydro,"magnetized_bondi_solution") || CCTK_Equals(initial_hydro,"hydro_bondi_solution")  ) { 
    if( num_bondi_sols > 1 ) { 
      CCTK_PARAMWARN("Currently only one Bondi solution is supported, please change [num_bondi_sols] ");
    }
  }

  if(CCTK_Equals(Bvec_evolution_method,"GRHydro") &&
     CCTK_Equals(initial_hydro,"magnetized_bondi_solution") &&
     CCTK_Equals(entropy_evolution_method,"GRHydro") &&
     !CCTK_Equals(initial_entropy,"magnetized Bondi") ){
      CCTK_PARAMWARN("Please set initial_entropy='magnetized Bondi' in order to initialize the entropy correctly!");
  }

  if(CCTK_Equals(entropy_evolution_method,"GRHydro")){
    *evolve_entropy = 1;
  }else{
    *evolve_entropy = 0;
  }
}

```

GRHydro_AlfvenWaveM.F90:
```
 /*@@
   @file      GRHydro_AlfvenWaveM.F90
   @date      Oct 10, 2011
   @author    Bruno Mundim, Joshua Faber, Scott Noble 
   @desc 
   Circularly Polarized Alfven Wave test as implemented by 
   Beckwith and Stone Astrophys.J.Suppl. 193 (2011) 6, arXiv:1101.3573, 
   and Del Zanna et. al. A&A 473, 11 (2007), arXiv:0704.3206;

   Other relevant references: 
     Stone et. al. Astrophys.J.Suppl. 178 (2008) 137, arXiv:0804.0402;  
     Gardiner and Stone JCP 227, 4123 (2008), arXiv:0712.2634;
     Toth JCP 161, 605 (2000);
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)
#define Bvecx(i,j,k) Bvec(i,j,k,1)
#define Bvecy(i,j,k) Bvec(i,j,k,2)
#define Bvecz(i,j,k) Bvec(i,j,k,3)
#define Bconsx(i,j,k) Bcons(i,j,k,1)
#define Bconsy(i,j,k) Bcons(i,j,k,2)
#define Bconsz(i,j,k) Bcons(i,j,k,3)


 /*@@
   @routine    GRHydro_AlfvenWaveM
   @date       Oct 10, 2011
   @author     Bruno Mundim, Joshua Faber, Scott Noble
   @desc 
   Initial data for Circularly Polarized Alfven Wave test
   @enddesc 
   @calls     
   @calledby   
   @history 
   Using GRHydro_AdvectedLoopM.F90 as a template.
   @endhistory 

@@*/

subroutine GRHydro_AlfvenWaveM(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT  :: i, j, k, nx, ny, nz
  CCTK_REAL :: pi,gam,AA,wnbr
  CCTK_REAL :: vxval,vyval,vzval, valf
  CCTK_REAL :: rhoval,pressval,epsval,hval
  CCTK_REAL :: Bxval, Byval, Bzval
  CCTK_REAL :: dx,dy,dz
  CCTK_REAL :: range_x,range_y,range_z,range_d
  CCTK_REAL :: cos_theta, sin_theta
  CCTK_REAL :: diaglength,xnew,vparallel,vperp,Bparallel,Bperp
  CCTK_REAL :: Bvecx_d, Bvecz_d
  CCTK_REAL :: velx_d, velz_d
  CCTK_REAL :: det
  CCTK_REAL :: t1,t2,t3

  pi=4.0d0*atan(1.0d0)

!!$Adiabatic index for this test:
  gam = (5.0d0/3.0d0)

!!$pressure, density, B^x, specific internal energy and enthalpy:
  rhoval   = 1.0d0
  pressval = alfvenwave_pressure
  Bxval    = 1.0d0
  epsval = pressval/(gam-1.0d0)/rhoval
  hval   = 1.0d0 + epsval + pressval/rhoval

!!$ DZ: rho=P=Bxval=AA = 1
!!$ Using DZ parameters, epsval=1.5, hval=3.5
  
!!$ Alfven Wave Amplitude:
  AA=1.0d0

!!$ Alfven wave speed:
  t1 = rhoval*hval+Bxval**2*(1.0d0+AA**2)
  t2 = 2.0d0*AA*Bxval**2/t1
  t3 = 0.5d0*(1.0d0+sqrt(1.0d0-t2**2))
  valf = sqrt(Bxval**2/t1/t3)

  write(*,*)'Alfven velocity:',valf

!!$ Using DZ parameters with P=1.0, we have:
!!$ t1=5.5
!!$ t2=4/11
!!$ t3=0.96577
!!$ valf=0.43389

!!$ Vx value:
   vxval=0.0d0
    
  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)

  dx = CCTK_DELTA_SPACE(1)
  dy = CCTK_DELTA_SPACE(2)
  dz = CCTK_DELTA_SPACE(3)

!!$ Note that the 3D test wasn't deviced to be used with AMR!
  range_x = (cctk_gsh(1)-2*cctk_nghostzones(1))*dx
  range_y = (cctk_gsh(2)-2*cctk_nghostzones(2))*dy
  range_z = (cctk_gsh(3)-2*cctk_nghostzones(3))*dz

!!$ Alfven wave number
  
  do i=1,nx
     do j=1,ny
        do k=1,nz

           rho(i,j,k)=rhoval
           press(i,j,k)=pressval
           eps(i,j,k)=epsval
          
           if (CCTK_EQUALS(alfvenwave_type,"1D")) then

             wnbr = 2.0d0*pi/range_x

             velx(i,j,k)=vxval
             vely(i,j,k)=-valf*AA*cos(wnbr*x(i,j,k))
             velz(i,j,k)=-valf*AA*sin(wnbr*x(i,j,k))
             Bvecx(i,j,k)=Bxval
             Bvecy(i,j,k)=AA*Bxval*cos(wnbr*x(i,j,k))
             Bvecz(i,j,k)=AA*Bxval*sin(wnbr*x(i,j,k))

           else if (CCTK_EQUALS(alfvenwave_type,"2D")) then
      
             diaglength=range_x*range_y/range_d
             range_d = sqrt(range_x**2+range_y**2)
             cos_theta = range_y/range_d
             sin_theta = range_x/range_d
             wnbr = 2.0d0*pi/diaglength

             xnew = cos_theta*x(i,j,k)+sin_theta*y(i,j,k)

             vparallel=vxval
             vperp=-valf*AA*cos(wnbr*xnew)
             velx(i,j,k)=vparallel*cos_theta-vperp*sin_theta
             vely(i,j,k)=vparallel*sin_theta+vperp*cos_theta
             velz(i,j,k)=-valf*AA*sin(wnbr*xnew)
             Bparallel=Bxval
             Bperp=AA*Bxval*cos(wnbr*xnew)
             Bvecx(i,j,k)=Bparallel*cos_theta-Bperp*sin_theta
             Bvecy(i,j,k)=Bparallel*sin_theta+Bperp*cos_theta
             Bvecz(i,j,k)=AA*Bxval*sin(wnbr*xnew)

           else
             call CCTK_WARN(0,"Alfven wave case not recognized!")
           end if 
     
           det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))
           
           if (CCTK_EQUALS(GRHydro_eos_type,"Polytype")) then
              call Prim2ConPolyM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
                   gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
                   det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
                   tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
                   velx(i,j,k),vely(i,j,k),velz(i,j,k),&
                   eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
                   w_lorentz(i,j,k))
           else
              call Prim2ConGenM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
                   gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
                   det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
                   tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
                   velx(i,j,k),vely(i,j,k),velz(i,j,k),&
                   eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
                   w_lorentz(i,j,k))
           end if
           
        enddo
     enddo
  enddo
  
  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0
  Bconsrhs = 0.d0

  return
  
end subroutine GRHydro_AlfvenWaveM



```

tov_lsoda.F:
```
#ifdef HAVE_ODEPACK
c===========================================================
c     History: sode.f
c
c     Driver routine which integrates ODEs defining 
c     TOV star
c 
c    Based on bstar.f by Matthew Choptuik
c===========================================================
      subroutine     tov_lsoda ( rho, p, m, alf,
     &                          r,  nr, tol , n_succ, ssrc) 

      implicit       none


      integer       vsrc,  vsxynt
      real*8         rho2p,         p2rho

      integer        nr
      real*8         rho(nr),p(nr), m(nr), alf(nr)
      real*8         r(nr)
      real*8         tol
      integer        n_succ, ssrc

      character*12    codenm
      parameter    ( codenm = 'tov_lsoda' )

      integer        iargc,         indlnb,         i4arg
      real*8         r8arg

      real*8         r8_never
      parameter    ( r8_never = -1.0d-60 )

c-----------------------------------------------------------
c     Order of system.
c-----------------------------------------------------------
      integer        neq
      parameter    ( neq = 3 )

c-----------------------------------------------------------
c     Storage for solution at requested output radii.
c-----------------------------------------------------------
      integer        maxout
      parameter    ( maxout = 10 000 )

      real*8         y0(neq)
      real*8         vxout(maxout), vyout(maxout,neq),
     &               work(maxout)
      integer        nxout,         ixout,       nxout_succ

      integer        ieq

      logical        ltrace
      parameter    ( ltrace = .false. )

      integer        maxdump
      parameter    ( maxdump = 50 )

      logical        lsodatrace
      parameter    ( lsodatrace = .false. )


c-----------------------------------------------------------
c     LSODA Variables.
c-----------------------------------------------------------
      external       tov_fcn,        tov_jac
      real*8         y(neq)
      real*8         tbgn,       tend
      integer        itol
      real*8         rtol,       atol
      integer        itask,      istate,     iopt
      integer        lrw

c      parameter    ( lrw = 22 + neq * max(16 ,neq + 9) )
      parameter    ( lrw = 22 + neq * (16) )
      real*8         rwork(lrw)

      integer        liw
      parameter    ( liw = 20 + neq )
      integer        iwork(liw)
      integer        jt

      integer        i

c-----------------------------------------------------------
c     Common communication with routine 'tov_fcn' in 'tov_fcn.f' ...
c-----------------------------------------------------------
c   rho0:  Value of rho at r=0
c-----------------------------------------------------------
      real*8  rho0
      common / com_tov / rho0

c-----------------------------------------------------------
c     Parse arguments.  
c-----------------------------------------------------------
      rho0    = rho(1)

      nxout   = nr
      do ixout = 1, nxout
         vxout(ixout) = r(ixout)
      enddo

c-----------------------------------------------------------
c     Initialize those "boundary" conditions which are 
c     fixed by regularity, or which are arbitrary.
c-----------------------------------------------------------
      y0(1) = rho2p(rho0)
      y0(2) = 0.0d0
      y0(3) = 1.0


c-----------------------------------------------------------
c     Echo command line arguments if "local tracing" 
c     enabled ...
c-----------------------------------------------------------
      if( ltrace ) then
         write(0,*) 'rho0: ', rho0
         write(0,*) 'p(1): ', y0(1)
         write(0,*) 'm(1): ', y0(2)
         write(0,*) 'alf(1): ', y0(3)
      end if

c-----------------------------------------------------------
c     Get output radii 
c-----------------------------------------------------------
      if( ltrace ) then
         if( nxout .le. maxdump ) then
            call dvdump(vxout,nxout,codenm//': output radii',0)
         else 
            call dvdmp1(vxout,work,
     &                  int(1.0d0 * nxout / maxdump + 0.5d0),
     &                  nxout,codenm//': selected output radii',0)
         end if
         write(0,*)
         write(0,*) codenm//': Initial time: ', vxout(1)
         write(0,*)
      end if

c-----------------------------------------------------------
c     Set LSODA parameters ...
c-----------------------------------------------------------
      itol   = 1
      rtol   = tol
      atol   = tol
      itask  = 1 
      iopt   = 0
      jt     = 2

c-----------------------------------------------------------
c     Initialize the solution ...
c-----------------------------------------------------------
      do ieq = 1 , neq
         y(ieq)       = y0(ieq)
         vyout(1,ieq) = y0(ieq)
      end do

c-----------------------------------------------------------
c     Do the integration ...
c-----------------------------------------------------------
      ssrc = 0
      do ixout = 2 , nxout
         istate = 1
c-----------------------------------------------------------
c        Need these temporaries since lsoda overwrites 
c        tend ... 
c-----------------------------------------------------------
100      continue
         tbgn = vxout(ixout-1)
         tend = vxout(ixout)
         call lsoda(tov_fcn,neq,y,tbgn,tend,
     &           itol,rtol,atol,itask,    
     &           istate,iopt,rwork,lrw,iwork,liw,tov_jac,jt)
         if( lsodatrace ) then
            write(0,1000) codenm, ixout, vxout(ixout), 
     &      vxout(ixout+1)
1000        format(' ',a,': Step ',i4,'  t = ',1pe10.3,
     &      ' .. ',1pe10.3)
            write(0,*) codenm//': lsoda reurns ', istate
         end if

c         if (istate .eq. -2) then
c            write(0,*) 'istate = -2, trying again...'
c            itol   = 1
c            rtol   = tol
c            atol   = tol
c            itask  = 1
c            iopt   = 0
c            jt     = 2
c            istate = 3
c            goto 100
c         endif

         if( istate .lt. -1 ) then
            write(0,1500) codenm, istate, ixout, nxout, 
     &                    vxout(ixout-1), vxout(ixout)
1500        format(/' ',a,': Error return ',i2,
     &              ' from integrator LSODA.'/
     &              '       At output time ',i5,' of ',i5/
     &              '       Interval ',1pe11.3,' .. ',
     &             1pe11.3/)
             nxout_succ = ixout - 1
             ssrc = 1
            go to 500

         end if

         do ieq = 1 , neq
            vyout(ixout,ieq) = y(ieq)
         end do

      end do
      nxout_succ = nxout

500   continue

c-----------------------------------------------------------
c     OUTPUT
c-----------------------------------------------------------
      do ixout = 1 , nxout_succ
         p(ixout)    = vyout(ixout, 1)
         m(ixout)    = vyout(ixout, 2)
         alf(ixout)    = vyout(ixout, 3)
         rho(ixout)    = p2rho(p(ixout))
      end do

      n_succ = nxout_succ

      return

      end





c===========================================================
c     Some double precision vector utility routines. 
c
c     Originally from ~matt/vutil/dveclib.f
c===========================================================
 
c-----------------------------------------------------------
c     Dumps vector labelled with LABEL on UNIT.
c-----------------------------------------------------------
      subroutine dvdump(v,n,label,unit)
         implicit       none

         real*8         v(*)
         character*(*)  label
         integer        i, n, st, unit
 
         if( n .lt. 1 ) go to 130
            write(unit,100) label
 100        format(/' <<< ',A,' >>>'/)
            st = 1
 110        continue
               write(unit,120) ( v(i) , i = st , min(st+3,n))
 120           FORMAT(' ',4(1PE19.10))
               st = st + 4
            if( st .le. n ) go to 110
 
 130     continue
 
         return
      end
 
c-----------------------------------------------------------
c     Extension of dvdump which dumps every 'inc'th element.
c-----------------------------------------------------------
      subroutine dvdmp1(v,w,inc,n,label,unit)
         implicit       none

         real*8         v(*),    w(*)
         character*(*)  label
         integer        inc,     n,      unit
 
         call dvinj(v,w,inc,n)
         call dvdump(w,1+(n-1)/inc,label,unit)

         return

      end
 
c---------------------------------------------------------
c     Injects every incth element of v1 into v2
c---------------------------------------------------------
      subroutine dvinj(v1,v2,inc,n)
         implicit    none
   
         real*8      v1(*),     v2(*)
         integer     i,         inc,     j,      n
 
         j = 1
         do i = 1 , n , inc
            v2(j) = v1(i)
            j = j + 1
         end do

 
         return
      end

#else
      subroutine tov_lsoda()
      return 
      end
 
#endif

```

GRHydro_ReconstructTest.F90:
```
 /*@@
   @file      GRHydro_ReconstructTest.F90
   @date      Sat Jan 26 02:51:49 2002
   @author    Luca Baiotti
   @desc 
   A test of the reconstruction algorithm.
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Parameters.h"

 /*@@
   @routine    GRHydro_reconstruction_test
   @date       Sat Jan 26 02:52:17 2002
   @author     Luca Baiotti
   @desc 
   Tests the reconstruction method by giving smoothly varying initial
   data with a shock along the x axis.
   @enddesc 
   @calls     
   @calledby   
   @history 
 
   @endhistory 

@@*/

subroutine GRHydro_reconstruction_test(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  
  integer i, j, k, nx, ny, nz, ierr

  logical, dimension(:,:,:), allocatable :: trivial_rp

  allocate(trivial_rp(cctk_lsh(1),cctk_lsh(2),cctk_lsh(3)),STAT=ierr)
  if (ierr .ne. 0) then
    call CCTK_WARN(0, "Allocation problems with trivial_rp")
  end if
  trivial_rp = .false.

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)
  
  xoffset = 1
  yoffset = 0
  zoffset = 0
  
  do k=1, cctk_lsh(3)
    do j=1, cctk_lsh(2)
      do i=1, cctk_lsh(1)
        if (i < 8) then 
          rho(i,j,k) = 5+sin(real(i+j+k)/2.)
        else 
          rho(i,j,k) = 1+sin(real(i+j+k)/2.)
        end if
      end do
    end do
  end do
  
  call tvdreconstruct(nx, ny, nz, xoffset, yoffset, zoffset, &
       rho, rhoplus, rhominus, trivial_rp, hydro_excision_mask)
  deallocate(trivial_rp)
  
  open(unit=11,file='original.dat',status='unknown')
  do  i=1, CCTK_LSH(1)
    write(11,*) i, rho(i,4,7)
    write(*,*) i, rho(i,4,7)
  end do
  close(11)
  
  open(unit=12,file='extensions.dat',status='unknown')
  do  i=2, CCTK_LSH(1)-1
    write(12,*) i-0.5, rhominus(i,4,7)
    write(12,*) i+0.5, rhoplus(i,4,7)
  end do
  close(12)
  
  
  write(*,*) 'test_reconstruction: done tvdreconstruct.'
  write(*,*) 'data written in files original.dat and extension.dat'
    
  stop
  
  return
  
end subroutine GRHydro_reconstruction_test

```

GRHydro_Only_Atmo.F90:
```
 /*@@
   @file      GRHydro_Only_Atmo.F90
   @date      Sat Jan 29 04:44:25 2002
   @author    Luca Baiotti
   @desc 
   Hydro initial data for vacuum.
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)

 /*@@
   @routine    GRHydro_Only_Atmo
   @date       Sat Jan 29 04:53:43 2002
   @author     Luca Baiotti
   @desc 
   Hydro initial data for vacuum.
   @enddesc 
   @calls     
   @calledby   
   @history 

   @endhistory 

@@*/

subroutine GRHydro_Only_Atmo(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  
  CCTK_INT i,j,k,nx,ny,nz
  CCTK_REAL det, atmo

  call CCTK_INFO("Setting only atmosphere as initial data.")

  
  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)
  
  if (rho_abs_min > 0.0) then
    atmo = rho_abs_min
    GRHydro_rho_min = rho_abs_min
  else 
    call CCTK_WARN(0,"For initial data 'only_atmo' the parameter 'rho_abs_min' must be set")
  end if
    
  if (initial_rho_abs_min > 0.0) then
    atmo = initial_rho_abs_min
  else if (initial_rho_rel_min > 0.0) then
    call CCTK_WARN(3,"For initial data 'only_atmo' the parameter 'initial_rho_rel_min' is ignored")
  end if

  if (initial_atmosphere_factor > 0.0) then
    atmo = atmo * initial_atmosphere_factor
  end if

  rho = atmo
  if (rho_abs_min < initial_rho_abs_min) then
    velx(:,:,:) = atmosphere_vel(1)
    vely(:,:,:) = atmosphere_vel(2)
    velz(:,:,:) = atmosphere_vel(3)
  else
    velx(:,:,:) = 0.d0
    vely(:,:,:) = 0.d0
    velz(:,:,:) = 0.d0
  end if
  if (attenuate_atmosphere .ne. 0) then
    velx(:,:,:) = velx(:,:,:) * (1.d0 - exp(-2.d0 * (r - 1.d0)**2))
    vely(:,:,:) = vely(:,:,:) * (1.d0 - exp(-2.d0 * (r - 1.d0)**2))
    velz(:,:,:) = velz(:,:,:) * (1.d0 - exp(-2.d0 * (r - 1.d0)**2))
  end if
  eps = GRHydro_eps_min

  do i=1,nx
    do j=1,ny
      do k=1,nz

!!$        if (x(i,j,k) < 0.0) then
!!$          velx(i,j,k) = -velx(i,j,k)
!!$          vely(i,j,k) = -vely(i,j,k)
!!$          velz(i,j,k) = -velz(i,j,k)
!!$        end if
        
        call SpatialDeterminant(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),&
             gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),det)
        call prim2con(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
             gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
             det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
             tau(i,j,k),rho(i,j,k),velx(i,j,k),vely(i,j,k),velz(i,j,k),&
             eps(i,j,k),press(i,j,k),w_lorentz(i,j,k))
      enddo
    enddo
  enddo

  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0

  return
  
end subroutine GRHydro_Only_Atmo

```

GRHydro_CylindricalExplosionM.F90:
```
 /*@@
   @file      GRHydro_CylindricalExplosionM.F90
   @date      Apr 22, 2011
   @author    Scott Noble, Joshua Faber, Bruno Mundim
   @desc 
   Cylindrical magnetized shocks.
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)
#define Bvecx(i,j,k) Bvec(i,j,k,1)
#define Bvecy(i,j,k) Bvec(i,j,k,2)
#define Bvecz(i,j,k) Bvec(i,j,k,3)
#define Bconsx(i,j,k) Bcons(i,j,k,1)
#define Bconsy(i,j,k) Bcons(i,j,k,2)
#define Bconsz(i,j,k) Bcons(i,j,k,3)


 /*@@
   @routine    GRHydro_cylindricalexplosionM
   @date       Fri Apr 22 14:51:37 EDT 2011
   @author     Scott Noble, Joshua Faber, Bruno Mundim
   @desc 
   Initial data for cylidrically symmetric shocks with 
   magnetic fields.  Meant to recreate tests demonstrated 
   in Komissarov (1999).
   @enddesc 
   @calls     
   @calledby   
   @history 
   Using GRHydro_ShockTubeM.F90 as a template.
   @endhistory 

@@*/

subroutine GRHydro_cylindricalexplosionM(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz
  CCTK_REAL :: direction, det
  CCTK_REAL :: rhol, rhor, pressl, pressr
  CCTK_REAL :: bvcxl,bvcyl,bvczl
  CCTK_REAL :: tmp,tmp2,gam,r_inner,r_outer

  CCTK_REAL :: cyl_fr

!!$ Check that user selected proper magnetic field ID. Warn if wrong one is
!!$ selected and proceed to ignore the value
  if (.not. CCTK_EQUALS(initial_Bvec, "cylexp")) then
    call CCTK_WARN(1, "When using the cyclindrical explosion initial data, please also select 'cylexp' for initial_Bvec. I will proceed as if this was set")
  end if

!!$Uses Bx_init, By_init and Bz_init to set magnetic field strength
!!$Original tests had Bx_init = 0.1, 1.0   with By_init=Bz_init = 0

  bvcxl = Bx_init
  bvcyl = By_init
  bvczl = Bz_init

!!$Inner radius and outer radius (Komissarov's defaults)
!  r_inner = 8.d-1
!  r_outer = 1.d0
  r_inner = cyl_r_inner
  r_outer = cyl_r_outer

!!$Inner values
  rhor   = cyl_rho_inner
  pressr = cyl_press_inner

!!$Outer values
  rhol   = cyl_rho_outer
  pressl = cyl_press_outer

!!$Adiabatic index for test
  gam = gl_gamma

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)

  do i=1,nx
    do j=1,ny
      do k=1,nz

!!$direction represents the cylindrical radius here.
!!$TODO: maybe switch these over so that shocktube_tube choses the axis of the
!!$cylinder instead of the apparently random mapping
        if (CCTK_EQUALS(shocktube_type,"xshock")) then
           direction = sqrt((x(i,j,k)-shock_xpos)**2+&
                (y(i,j,k)-shock_ypos)**2)
        else if (CCTK_EQUALS(shocktube_type,"yshock")) then
           direction = sqrt((y(i,j,k)-shock_ypos)**2+&
                (z(i,j,k)-shock_zpos)**2)
        else if (CCTK_EQUALS(shocktube_type,"zshock")) then
           direction = sqrt((x(i,j,k)-shock_xpos)**2+&
                (z(i,j,k)-shock_zpos)**2)
        end if

        tmp = cyl_fr(direction,r_inner,r_outer,rhol,rhor)
        tmp2 = cyl_fr(direction,r_inner,r_outer,pressl,pressr)/( (gam - 1.d0) * tmp ) 
        rho(i,j,k) = tmp
        eps(i,j,k) = tmp2

        velx(i,j,k) = 0.d0
        vely(i,j,k) = 0.d0
        velz(i,j,k) = 0.d0
        Bvecx(i,j,k)=bvcxl
        Bvecy(i,j,k)=bvcyl
        Bvecz(i,j,k)=bvczl

        det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))

        if (CCTK_EQUALS(GRHydro_eos_type,"Polytype")) then
          call Prim2ConPolyM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
               gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
               det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
               tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k),&
               eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
               w_lorentz(i,j,k))
        else
          call Prim2ConGenM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
               gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
               det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
               tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k),&
               eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
               w_lorentz(i,j,k))
        end if

     enddo
    enddo
  enddo

  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0
  Bconsrhs = 0.d0


  return
  
end subroutine GRHydro_CylindricalExplosionM



function cyl_fr(R,r_inner,r_outer,min_f,max_f)

  implicit none

  CCTK_REAL :: cyl_fr
  CCTK_REAL :: R,r_inner,r_outer,min_f,max_f

  if(R .gt. r_outer) then 
     cyl_fr = min_f
  else if( R .lt. r_inner) then 
     cyl_fr = max_f
  else 
     cyl_fr = exp( ( log(max_f)*(r_outer - R) + log(min_f)*(R - r_inner) ) / (r_outer - r_inner) ) 
  end if

  return 

end function cyl_fr

```

GRHydro_C2P2C.F90:
```
 /*@@
   @file      GRHydro_C2P2C.F90
   @date      Sat Jan 26 02:44:43 2002
   @author    Luca Baiotti
   @desc 
   A test of the conservative <--> primitive variable exchange
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"

 /*@@
   @routine    c2p2c
   @date       Sat Jan 26 02:45:19 2002
   @author     Luca Baiotti
   @desc 
   Testing the conservative <--> primitive variable transformations.
   The values before and after should match.
   @enddesc 
   @calls     
   @calledby   
   @history 
 
   @endhistory 

@@*/

subroutine c2p2c(CCTK_ARGUMENTS)

  implicit none

  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS

  CCTK_REAL :: det
  CCTK_REAL :: uxx,uxy,uxz,uyy,uyz,uzz
  CCTK_REAL :: gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send
  CCTK_REAL :: dens_send,sx_send,sy_send,sz_send,tau_send
  CCTK_REAL :: rho_send,velx_send,vely_send,velz_send,eps_send
  CCTK_REAL :: press_send,w_lorentz_send,x_send,y_send,z_send,r_send
  CCTK_REAL :: C2P_failed
  CCTK_INT :: epsnegative

! begin EOS Omni vars
  CCTK_REAL :: pmin(1), epsmin(1), epsval(1)
  CCTK_INT :: n,keytemp,anyerr,keyerr(1)
  CCTK_REAL :: xpress(1),xtemp(1),xye(1),xeps(1),xrho(1)
  n=1;keytemp=0;anyerr=0;keyerr(1)=0
  xpress(1)=0.0d0;xtemp(1)=0.0d0;xye(1)=0.0d0;xeps(1)=0.0d0
! end EOS Omni vars

  call CCTK_WARN(1,"This test works only with Ideal_Fluid EoS")
  
  x_send = 0.0d0
  y_send = 0.0d0
  z_send = 0.0d0
  r_send = 0.0d0
  
  gxx_send = 1.0d0
  gyy_send = 1.0d0 
  gzz_send = 1.0d0
  gxy_send = 0.0d0
  gxz_send = 0.0d0
  gyz_send = 0.0d0
  
  det = 1.0d0
  
  uxx = 1.0d0
  uyy = 1.0d0 
  uzz = 1.0d0
  uxy = 0.0d0
  uxz = 0.0d0
  uyz = 0.0d0
  
  dens_send = 1.29047362d0
  sx_send   = 0.166666658d0
  sy_send   = 0.166666658d0
  sz_send   = 0.166666658d0
  tau_send  = 0.484123939d0
  
  eps_send = 1.0d-6
  press_send = 6.666666666666667d-7
  w_lorentz_send = 1.0d0

  epsnegative = 0
  
  xrho = 1.0d-10
  epsval = 1.0d0

  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,epsval,xtemp,xye,pmin,keyerr,anyerr)

  call EOS_Omni_EpsFromPress(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,xeps,xtemp,xye,pmin,epsmin,keyerr,anyerr)

  C2P_failed = 0.0d0

  write(*,*) 'C2P2C test: initial values.'
  write(*,*) '   conservative variables: '
  write(*,*) '   dens: ',dens_send
  write(*,*) '   sx  : ',sx_send
  write(*,*) '   sy  : ',sy_send
  write(*,*) '   sz  : ',sz_send
  write(*,*) '   tau : ',tau_send
  write(*,*) '   eps : ',eps_send
  write(*,*) '   W   : ',w_lorentz_send
  
  write(*,*) 'C2P2C test: getting the associated primitive variables.'
  call Con2PrimGen(GRHydro_eos_handle,dens_send,sx_send,sy_send,sz_send, &
       tau_send,rho_send,velx_send,vely_send,velz_send, &
       eps_send,press_send,w_lorentz_send, &
       uxx,uxy,uxz,uyy,uyz,uzz,det,x_send,y_send,z_send,r_send,&
       epsnegative,xrho(1),pmin(1),epsmin(1),GRHydro_init_data_reflevel,C2P_failed)
  
  write(*,*) 'C2P2C test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   W     : ',w_lorentz_send
  
  write(*,*) 'C2P2C test: converting back to conserved variables.'
  call Prim2ConGen(GRHydro_eos_handle, &
       gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,det, &
       dens_send,sx_send,sy_send,sz_send,tau_send,rho_send, &
       velx_send,vely_send,velz_send,eps_send,press_send,w_lorentz_send) 
  
  write(*,*) 'C2P2C test: the conserved variables are'
  write(*,*) '   conservative variables: '
  write(*,*) '   dens: ',dens_send
  write(*,*) '   sx  : ',sx_send
  write(*,*) '   sy  : ',sy_send
  write(*,*) '   sz  : ',sz_send
  write(*,*) '   tau : ',tau_send
  write(*,*) '   eps : ',eps_send
  write(*,*) '   W   : ',w_lorentz_send
  
  STOP

  return

end subroutine c2p2c

```

make.configuration.deps:
```

# the TOV solver uses lsoda, which comes with the odepack library
# Currently the Cactus configure script doesn't check for this
# Thus the user needs to set an environment variable, ODEPACK_DIR
# -Scott Hawley

# Remove by IH.


```

GRHydro_RotorM.F90:
```
 /*@@
   @file      GRHydro_RotorM.F90
   @date      Aug 15, 2011
   @author    Scott Noble, Joshua Faber, Bruno Mundim
   @desc 
   Cylindrical magnetized rotor test (see Etienne et al.).
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)
#define Bvecx(i,j,k) Bvec(i,j,k,1)
#define Bvecy(i,j,k) Bvec(i,j,k,2)
#define Bvecz(i,j,k) Bvec(i,j,k,3)
#define Bconsx(i,j,k) Bcons(i,j,k,1)
#define Bconsy(i,j,k) Bcons(i,j,k,2)
#define Bconsz(i,j,k) Bcons(i,j,k,3)


 /*@@
   @routine    GRHydro_Rotor
   @date       Aug 11, 2011
   @author     Scott Noble, Joshua Faber, Bruno Mundim
   @desc 
   Initial data for magnetic rotor - parameters from Etienne et al. 2010
   @enddesc 
   @calls     
   @calledby   
   @history 
   Using GRHydro_ShockTubeM.F90 as a template.
   @endhistory 

@@*/

subroutine GRHydro_RotorM(CCTK_ARGUMENTS)

  use cctk

  implicit none

  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS

  CCTK_INT :: i, j, k, nx, ny, nz
  CCTK_REAL :: radius, det, rfact

  !begin EOS_Omni stuff
  CCTK_REAL :: tempEOS(1), yeEOS(1), xepsEOS(1)
  CCTK_INT :: keyerr(1), anyerr
  CCTK_INT, parameter :: have_temp = 0, n = 1
  !end EOS_Omni

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)

  !$OMP PARALLEL DO PRIVATE(i,j,k,radius,det,rfact,tempEOS,yeEOS,xepsEOS,keyerr,anyerr) &
  !$OMP default(none) &
  !$OMP firstprivate(nx,ny,nz,GRHydro_eos_handle, GRHydro_eos_rf_prec, grhydro_eos_type, &
  !$OMP              rotor_xc,rotor_yc, rotor_rsmooth_rel, rotor_use_smoothing, &
  !$OMP              rotor_r_rot, rotor_rhoin,rotor_pressin,rotor_rhoout,rotor_pressout, &
  !$OMP              rotor_v_max, rotor_bvcxl, rotor_bvcyl, rotor_bvczl) &
  !$OMP shared(x,y,z,rho,press,eps,vel,Bvec,w_lorentz,dens,Scon,tau,Bcons, &
  !$OMP        gxx,gxy,gxz,gyy,gyz,gzz)
  do i=1,nx
     do j=1,ny
        do k=1,nz

           radius = sqrt((x(i,j,k)-rotor_xc)**2+(y(i,j,k)-rotor_yc)**2)

           if(radius.le.rotor_r_rot) then
              rho(i,j,k) = rotor_rhoin
              press(i,j,k) = rotor_pressin
              velx(i,j,k) = -1.d0*rotor_v_max/rotor_r_rot*(y(i,j,k)-rotor_yc)
              vely(i,j,k) = +1.d0*rotor_v_max/rotor_r_rot*(x(i,j,k)-rotor_xc)
              velz(i,j,k) = 0.d0
           else if((rotor_use_smoothing.eq.1) .and. &
                ((radius.gt.rotor_r_rot) .and. &
                (radius.le.((1.0+rotor_rsmooth_rel)*rotor_r_rot)))) then
              rfact = (radius/rotor_r_rot - 1.d0) / rotor_rsmooth_rel
              rho(i,j,k) = rfact*rotor_rhoout + (1.d0-rfact)*rotor_rhoin
              press(i,j,k) = rfact*rotor_pressout + (1.d0-rfact)*rotor_pressin
              velx(i,j,k) = -1.d0*(1.d0-rfact)*rotor_v_max * (y(i,j,k)-rotor_yc) / radius
              velx(i,j,k) = +1.d0*(1.d0-rfact)*rotor_v_max * (x(i,j,k)-rotor_xc) / radius
              velz(i,j,k) = 0.d0
           else
              rho(i,j,k) = rotor_rhoout
              press(i,j,k) = rotor_pressout
              velx(i,j,k) = 0.d0
              vely(i,j,k) = 0.d0
              velz(i,j,k) = 0.d0
           endif
           keyerr = 0; anyerr = 0
           call EOS_Omni_EpsFromPress(GRHydro_eos_handle, have_temp, GRHydro_eos_rf_prec, &
                                      n, rho(i:i,j:j,k:k), eps(i:i,j:j,k:k), &
                                      tempEOS, yeEOS, press(i:i,j:j,k:k), &
                                      eps(i:i,j:j,k:k), & ! xeps argument
                                      keyerr, anyerr)
           if(anyerr .ne. 0) then
              call CCTK_WARN(0, "Error when calling EOS. After stopping swearing at me, add a decent output text.")
           end if

           Bvecx(i,j,k)=rotor_bvcxl
           Bvecy(i,j,k)=rotor_bvcyl
           Bvecz(i,j,k)=rotor_bvczl

           det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))
           if(abs(det - 1d0) .gt. 1e-8) then
              call CCTK_WARN(0, "Rotor initial data only supports flat spacetime right now")
           end if

           if (CCTK_EQUALS(GRHydro_eos_type,"Polytype")) then
              call Prim2ConPolyM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
                   gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
                   det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
                   tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
                   velx(i,j,k),vely(i,j,k),velz(i,j,k),&
                   eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
                   w_lorentz(i,j,k))
           else
              call Prim2ConGenM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
                   gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
                   det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
                   tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
                   velx(i,j,k),vely(i,j,k),velz(i,j,k),&
                   eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
                   w_lorentz(i,j,k))
           end if

        enddo
     enddo
  enddo
  !$OMP END PARALLEL DO

end subroutine GRHydro_RotorM



```

GRHydro_P2C2PM.F90:
```
 /*@@
   @file      GRHydro_P2C2PM.F90
   @date      Sep 25, 2010
   @author    Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   A test of the conservative <--> primitive variable exchange
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"

 /*@@
   @routine    p2c2pm
   @date       Sep 25, 2010
   @author     Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   Testing the conservative <--> primitive variable transformations.
   The values before and after should match.
   @enddesc 
   @calls     
   @calledby   
   @history 
 
   @endhistory 

@@*/

subroutine p2c2pm(CCTK_ARGUMENTS)

  implicit none

  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS

  CCTK_REAL :: det
  CCTK_REAL :: uxx,uxy,uxz,uyy,uyz,uzz
  CCTK_REAL :: gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send
  CCTK_REAL :: dens_send,sx_send,sy_send,sz_send,tau_send
  CCTK_REAL :: bconsx_send,bconsy_send,bconsz_send
  CCTK_REAL :: rho_send(1),velx_send,vely_send,velz_send,eps_send(1)
  CCTK_REAL :: press_send(1),w_lorentz_send,x_send,y_send,z_send,r_send
  CCTK_REAL :: bvcx_send,bvcy_send,bvcz_send,b2_send
  CCTK_REAL :: C2P_failed
  CCTK_INT :: epsnegative

! begin EOS Omni vars
  CCTK_REAL :: pmin(1), epsmin(1), local_gam(1), epsval(1)
  CCTK_INT :: n,keytemp,anyerr,keyerr(1)
  CCTK_REAL :: xpress(1),xtemp(1),xye(1),xeps(1),xrho(1)
  n=1;keytemp=0;anyerr=0;keyerr(1)=0
  xpress(1)=0.0d0;xtemp(1)=0.0d0;xye(1)=0.0d0;xeps(1)=0.0d0
! end EOS Omni vars

  call CCTK_WARN(1,"This test works only with Ideal_Fluid EoS")
  
  x_send = 0.0d0
  y_send = 0.0d0
  z_send = 0.0d0
  r_send = 0.0d0
  
  gxx_send = 1.0d0
  gyy_send = 1.0d0 
  gzz_send = 1.0d0
  gxy_send = 0.0d0
  gxz_send = 0.0d0
  gyz_send = 0.0d0
  
  det = 1.0d0
  
  uxx = 1.0d0
  uyy = 1.0d0 
  uzz = 1.0d0
  uxy = 0.0d0
  uxz = 0.0d0
  uyz = 0.0d0
  
  rho_send = 1.29047362d0
  velx_send   = 0.166666658d0
  vely_send   = 0.166666658d0
  velz_send   = 0.166666658d0
  eps_send  = 0.484123939d0
  
  bvcx_send   = Bx_init
  bvcy_send   = By_init
  bvcz_send   = Bz_init
  bconsx_send   = Bx_init
  bconsy_send   = By_init
  bconsz_send   = Bz_init

  w_lorentz_send = 1.d0/sqrt(1.0d0-velx_send*velx_send-vely_send*vely_send-velz_send*velz_send)

  epsnegative = 0
  
  xrho = 1.0d-10
  epsval = 1.0d0

  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       rho_send,eps_send,xtemp,xye,press_send,keyerr,anyerr)
  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,epsval,xtemp,xye,pmin,keyerr,anyerr)

  call EOS_Omni_EpsFromPress(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,xeps,xtemp,xye,pmin,epsmin,keyerr,anyerr)

  local_gam = 0.0d0
  xrho = 1.0d0
  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,epsval,xtemp,xye,local_gam,keyerr,anyerr)
  local_gam = local_gam + 1.0

  C2P_failed = 0.0d0

  write(*,*) 'P2C2PM test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   W     : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  write(*,*) 'P2C2PM test: converting back to conserved variables.'
  call Prim2ConGenM(GRHydro_eos_handle,&
       gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,det, &
       dens_send,sx_send,sy_send,sz_send,tau_send, &
       bconsx_send,bconsy_send,bconsz_send, &
       rho_send(1),velx_send,vely_send,velz_send,eps_send(1),press_send(1), &
       bvcx_send,bvcy_send,bvcz_send,w_lorentz_send) 

  write(*,*) 'P2C2PM test: initial values.'
  write(*,*) '   conservative variables: '
  write(*,*) '   dens: ',dens_send
  write(*,*) '   sx  : ',sx_send
  write(*,*) '   sy  : ',sy_send
  write(*,*) '   sz  : ',sz_send
  write(*,*) '   tau : ',tau_send
  write(*,*) '   Bconsx  : ',bconsx_send
  write(*,*) '   Bconsy  : ',bconsy_send
  write(*,*) '   Bconsz  : ',bconsz_send
  write(*,*) '   eps : ',eps_send
  write(*,*) '   W   : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  write(*,*) 'P2C2PM test: getting the associated primitive variables.'
  
  call Con2PrimGenM(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,local_gam(1),dens_send,sx_send,sy_send,sz_send, &
       tau_send,bconsx_send,bconsy_send,bconsz_send,&
       xtemp(1),xye(1),rho_send(1),velx_send,vely_send,velz_send, &
       eps_send(1),press_send(1), &      
       bvcx_send,bvcy_send,bvcz_send,b2_send,&
       w_lorentz_send, &
       gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,&
       uxx,uxy,uxz,uyy,uyz,uzz,det,&
       epsnegative,C2P_failed)
  
  write(*,*) 'P2C2PM test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   W     : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  STOP

  return

end subroutine p2c2pm

```

GRHydro_SimpleWave.F90:
```

 /*@@
   @file      GRHydro_SimpleWave.F90
   @date      Thu Aug  2 15:17:35 2007
   @author    Luca Baiotti
   @desc 
   Initial data for a simple wave with sinusoidal initial function for the velocity
     See Anile, Miller, Motta, Formation and damping of relativistic strong shocks,  
         Phys. Fluids 26, 1450 (1983)
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)

 /*@@
   @routine    GRHydro_SimpleWave
   @date       Thu Aug  2 15:20:28 2007
   @author     Luca Baiotti
   @desc 
   Initial data for a simple wave with sinusoidal initial function for the velocity
     See Anile, Miller, Motta, Formation and damping of relativistic strong shocks,  
         Phys. Fluids 26, 1450 (1983)
   @enddesc 
   @calls     
   @calledby   
   @history 
   @endhistory 

@@*/

subroutine GRHydro_SimpleWave(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz
  CCTK_REAL :: dr, k1, k2, k3, k4, in_data, old_data, source_data, new_data, c_0, det, pi

! begin EOS Omni vars
  CCTK_INT  :: n = 1
  CCTK_INT  :: keytemp = 0
  CCTK_INT  :: anyerr = 0
  CCTK_INT  :: keyerr(1) = 0
  CCTK_REAL :: xpress(1) = 0.0d0
  CCTK_REAL :: xeps(1) = 0.0d0
  CCTK_REAL :: xtemp(1) = 0.0d0
  CCTK_REAL :: xye(1) = 0.0d0
  CCTK_REAL :: rf_precision = 1.0d-10
! end EOS Omni vars
  
  call CCTK_INFO("Setting initial data for a simple wave as Anile Miller Motta")

  call CCTK_WARN(1, "The simple-wave initial-data routine works only for unigrid and on one node.")
  
  pi = 4.d0 * atan(1.0)

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)

  velx(:,:,:) = 0.0
  rho = 0.0
  eps = 0.0
  press = 0.0
  w_lorentz = 0.0
  simple_tmp = 0.0

  i = 0
  do while (minval(velx(:,1,1)) >= 0.0)
    i=i+1
    if (x(i,1,1) > 0.0) velx(i,1,1) = simple_wave_v_max * sin(pi * x(i,1,1))
  end do

  velx(i,1,1) = 0.0 ! set the first term that became negative to zero

  c_0 = simple_wave_constant_c_0 ! a parameter

    ! compute quantities at v=0

  simple_eps_0 = 9.d0*c_0**2 /(4.d0 * (1.d0 - 3.d0 * c_0**2))

  simple_rho_0 = simple_eps_0**3.d0

!  press_0 = eps_0**4.d0
  
!   do j = 1,i
   do j = 1,CCTK_LSH(1)
  
    simple_tmp(j,1,1) = ( 1.d0 + c_0*sqrt(3.d0) )/( 1.d0 - c_0*sqrt(3.d0) ) &
         * ( (1+velx(j,1,1))/(1-velx(j,1,1)) )**(1/(2.d0*sqrt(3.d0)))
    
    c_s(j,1,1) = ( simple_tmp(j,1,1) - 1.d0 ) / ( sqrt(3.d0)* ( simple_tmp(j,1,1) + 1.d0 ) )
    
    eps(j,1,1) = 9.d0*c_s(j,1,1)**2 /(4.d0 * (1.d0 - 3.d0 * c_s(j,1,1)**2))    
   
    rho(j,1,1) = eps(j,1,1)**3.d0
! write(*,*) j, x(j,1,1), rho(j,1,1)
!    rho(j,1,1) = rho_abs_min * rho(j,1,1)
    
    press(j,1,1) = eps(j,1,1)**(4.d0)
    
    w_lorentz(j,1,1) = 1.d0/sqrt(1.d0-velx(j,1,1)**2) ! flat spacetime
    
  end do

  !arrays
  gxx = 1.d0; gyy=1.d0; gzz=1.d0; gxy=0.d0; gxz=0.d0; gyz=0.d0
  
  

!!$  do i = 1,CCTK_LSH(1)
!!$    
!!$    write(*,*) i, x(i,1,1), velx(i,1,1), rho(i,1,1)
!!$    write(*,*) eps(i,1,1), press(i,1,1), w_lorentz(i,1,1)
!!$
!!$  end do



  do i=1,nx
    
    ! atmosphere

     if ( (rho(i,1,1) < GRHydro_rho_min).OR.(velx(i,1,1) < 0) ) then
        rho(i,1,1) = rho_abs_min
        !      rho(i,1,1) = 1.0 !the value of rho_min for the initial data
        eps(i,1,1) = rho_abs_min**(1.d0/3.d0)
        velx(i,1,1) = 0.d0
        w_lorentz(i,1,1) = 1.d0
        
        xeps = 1.0d0
        call EOS_Omni_press(GRHydro_polytrope_handle,keytemp,rf_precision,n,&
             rho(i,1,1),xeps,xtemp,xye,press(i,1,1),keyerr,anyerr)
        
        ! polytrope only (initial data)
     end if

!    write(*,*) 'p',i, x(i,1,1), rho(i,1,1)**(4.d0/3.d0)/press(i,1,1)    
    
    call SpatialDet(gxx(i,1,1),gxy(i,1,1),gxz(i,1,1),&
         gyy(i,1,1),gyz(i,1,1),gzz(i,1,1),det)
    
!    if (CCTK_EQUALS(GRHydro_eos_type,"Polytype")) then
    ! always use polytype for initial data
      call Prim2ConPoly(GRHydro_polytrope_handle,gxx(i,1,1),gxy(i,1,1),&
           gxz(i,1,1),gyy(i,1,1),gyz(i,1,1),gzz(i,1,1),&
           det, dens(i,1,1),sx(i,1,1),sy(i,1,1),sz(i,1,1),&
           tau(i,1,1),rho(i,1,1),&
           velx(i,1,1),vely(i,1,1),velz(i,1,1),&
           eps(i,1,1),press(i,1,1),w_lorentz(i,1,1))
!!$    else
!!$      call Prim2ConGen(GRHydro_eos_handle,gxx(i,1,1),gxy(i,1,1),&
!!$           gxz(i,1,1),gyy(i,1,1),gyz(i,1,1),gzz(i,1,1),&
!!$           det, dens(i,1,1),sx(i,1,1),sy(i,1,1),sz(i,1,1),&
!!$           tau(i,1,1),rho(i,1,1),&
!!$           velx(i,1,1),vely(i,1,1),velz(i,1,1),&
!!$           eps(i,1,1),press(i,1,1),w_lorentz(i,1,1))
!!$    end if
!!$    

!      write(*,*) 'd',i, x(i,1,1), rho(i,1,1)**(4.d0/3.d0)/press(i,1,1)

  enddo
  
  
  ! planar symmetry
  do j=1,ny
    do k=1,nz
      
      velx(:,j,k)   = velx(:,1,1)
      rho(:,j,k)    = rho(:,1,1)
      eps(:,j,k)    = eps(:,1,1)
      press(:,j,k)  = press(:,1,1)
      w_lorentz(:,j,k)  = w_lorentz(:,1,1)

      sx(:,j,k)   = sx(:,1,1)
      dens(:,j,k)   = dens(:,1,1)
      tau(:,j,k)   = tau(:,1,1)
     
    enddo
  enddo
  
  
  vely(:,:,:) = 0.d0
  velz(:,:,:) = 0.d0
  
  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0

  simple_tmp = rho



!!$  do i = 1,CCTK_LSH(1)
!!$
!!$    do j = 1,CCTK_LSH(2)
!!$
!!$      do k = 1,CCTK_LSH(3)
!!$
!!$        write(*,*) i, x(i,j,k), velx(i,j,k)
!!$        write(*,*) eps(i,j,k), press(i,j,k), rho(i,j,k)
!!$
!!$      end do
!!$    end do
!!$  end do


call CCTK_INFO("Finished initial data")

  return
  
end subroutine GRHydro_SimpleWave


subroutine GRHydro_SimpleWave_Analysis(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS

  if (velx(CCTK_LSH(1),1,1) == 0.0) then
    simple_eps_0 = eps(CCTK_LSH(1),1,1)
  else
    call CCTK_WARN(1,"The wave has reached the outer boundary: the computation of simple_eps is now wrong")
  end if

  simple_rho = (rho - simple_rho_0)/simple_rho_0
  simple_eps = (eps - simple_eps_0)/simple_eps_0


  return

end subroutine GRHydro_SimpleWave_Analysis

```

make.code.defn:
```
# Main make.code.defn file for thorn Hydra_Init_Data
# $Header: /GRHydro/GRHydro_Dev/GRHydro_Init_Data/src/make.code.defn,v 1.6 2004/04/28 17:30:18 hawke Exp $

# Source files in this directory
SRCS = 	GRHydro_C2P2C.F90 \
	GRHydro_C2P2CM.F90 \
	GRHydro_Con2Prim.F90 \
	GRHydro_ReconstructTest.F90 \
	GRHydro_ShockTube.F90 \
	GRHydro_ShockTubeM.F90 \
	GRHydro_Only_Atmo.F90 \
	GRHydro_ReadConformalData.F90 \
	GRHydro_SimpleWave.F90 \
   CheckParam.c\
   GRHydro_P2C2P.F90 \
   GRHydro_P2C2PM.F90 \
   GRHydro_P2C2PM_polytype.F90 \
   GRHydro_MonopoleM.F90 \
   GRHydro_CylindricalExplosionM.F90 \
   GRHydro_RotorM.F90 \
   GRHydro_AdvectedLoopM.F90 \
   GRHydro_AlfvenWaveM.F90 \
   GRHydro_Bondi.c \
   GRHydro_BondiM.c \
   GRHydro_PoloidalMagFieldM.F90 \
   GRHydro_Bondi_new.F90 \
   GRHydro_BondiM_new.F90 

# Subdirectories containing source files
SUBDIRS = 


```

GRHydro_MonopoleM.F90:
```
 /*@@
   @file      GRHydro_MonopoleM.F90
   @date      Sep 23, 2010
   @author    Joshua Faber, Scott Noble, Bruno Mundim, Ian Hawke
   @desc 
   Initial data of the shock tube type - MHD version.
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)
#define Bvecx(i,j,k) Bvec(i,j,k,1)
#define Bvecy(i,j,k) Bvec(i,j,k,2)
#define Bvecz(i,j,k) Bvec(i,j,k,3)
#define Bconsx(i,j,k) Bcons(i,j,k,1)
#define Bconsy(i,j,k) Bcons(i,j,k,2)
#define Bconsz(i,j,k) Bcons(i,j,k,3)

 /*@@
   @routine    GRHydro_MonopoleM
   @date       Sat Jan 26 02:53:49 2002
   @author     Joshua Faber, Scott Noble, Bruno Mundim, Ian Hawke
   @desc 
   A monopole in space
   @enddesc 
   @calls     
   @calledby   
   @history 
   Expansion and alteration of the test code from GRAstro_Hydro, 
   written by Mark Miller.
   @endhistory 

@@*/

subroutine GRHydro_MonopoleM(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz
  CCTK_REAL :: direction, det
  CCTK_REAL :: rhol, rhor, velxl, velxr, velyl, velyr, &
       velzl, velzr, epsl, epsr
  CCTK_REAL :: bvcxl,bvcyl,bvczl,bvcxr,bvcyr,bvczr
  CCTK_REAL :: ux,uy,uz,ut,tmp,tmp2,tmp3
  CCTK_REAL :: rr2,rg2
  
  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)
  
  do i=1,nx
     do j=1,ny
        do k=1,nz
           
           rho(i,j,k) = 1.0
           velx(i,j,k) = 0.0
           vely(i,j,k) = 0.0
           velz(i,j,k) = 0.0
           eps(i,j,k) = 0.1

           Bvecx(i,j,k)=0.0
           Bvecy(i,j,k)=0.0
           Bvecz(i,j,k)=0.0

           if(CCTK_EQUALS(monopole_type,"Point")) then
              if(i.eq.nx/2+1.and.j.eq.ny/2+1.and.k.eq.nz/2+1) then
                 Bvecx(i,j,k)=Monopole_point_Bx
              else
                 Bvecx(i,j,k)=0.0
              endif
           else if(CCTK_EQUALS(monopole_type,"Gauss")) then
              rr2=x(i,j,k)**2+y(i,j,k)**2+z(i,j,k)**2
              rg2=R_Gauss*R_Gauss
              if(rr2.lt.rg2) then
                 Bvecx(i,j,k) = exp(-1.0*rr2/rg2)-1.0/exp(1.0)
              else
                 Bvecx(i,j,k) = 0.0
              endif
           else if(CCTK_EQUALS(monopole_type,"1dalt")) then
              rr2=x(i,j,k)**2+y(i,j,k)**2+z(i,j,k)**2
              rg2=R_Gauss*R_Gauss
              if(rr2.lt.rg2) then
                 Bvecx(i,j,k) = exp(-1.0*rr2/rg2)-1.0/exp(1.0)
              else
                 Bvecx(i,j,k) = 0.0
              endif
              if(mod(i+j+k,2).eq.0)Bvecx(i,j,k)=-1.0*Bvecx(i,j,k)
           else if(CCTK_EQUALS(monopole_type,"2dalt")) then
              rr2=x(i,j,k)**2+y(i,j,k)**2+z(i,j,k)**2
              rg2=R_Gauss*R_Gauss
              if(rr2.lt.rg2) then
                 Bvecx(i,j,k) = exp(-1.0*rr2/rg2)-1.0/exp(1.0)
                 Bvecy(i,j,k) = exp(-1.0*rr2/rg2)-1.0/exp(1.0)
              else
                 Bvecx(i,j,k) = 0.0
                 Bvecy(i,j,k) = 0.0
              endif
              if(mod(i+j+k,2).eq.0)then
                 Bvecx(i,j,k)=-1.0*Bvecx(i,j,k)
!!$  Only vary one component, for different character
!!$                 Bvecy(i,j,k)=-1.0*Bvecy(i,j,k)
              endif
           else if(CCTK_EQUALS(monopole_type,"3dalt")) then
              rr2=x(i,j,k)**2+y(i,j,k)**2+z(i,j,k)**2
              rg2=R_Gauss*R_Gauss
              if(rr2.lt.rg2) then
                 Bvecx(i,j,k) = exp(-1.0*rr2/rg2)-1.0/exp(1.0)
                 Bvecy(i,j,k) = exp(-1.0*rr2/rg2)-1.0/exp(1.0)
                 Bvecz(i,j,k) = exp(-1.0*rr2/rg2)-1.0/exp(1.0)
              else
                 Bvecx(i,j,k) = 0.0
                 Bvecy(i,j,k) = 0.0
                 Bvecz(i,j,k) = 0.0
              endif
!!$  Different spatial pattern!
              if(mod(i+j,2).eq.0)then
                 Bvecx(i,j,k)=-1.0*Bvecx(i,j,k)
                 Bvecy(i,j,k)=-1.0*Bvecy(i,j,k)
                 Bvecz(i,j,k)=-1.0*Bvecz(i,j,k)
              endif
           else
              call CCTK_WARN(0,"Unrecognized monopole type!!!")
           endif

           det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))

        if (CCTK_EQUALS(GRHydro_eos_type,"Polytype")) then
          call Prim2ConPolyM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
               gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
               det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
               tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k),&
               eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
               w_lorentz(i,j,k))
        else
          call Prim2ConGenM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
               gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
               det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
               tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k),&
               eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
               w_lorentz(i,j,k))
        end if

        enddo
     enddo
  enddo

  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0
  Bconsrhs = 0.d0


  return
  
end subroutine GRHydro_MonopoleM

```

GRHydro_BondiM.c:
```
 /*@@
   @file      GRHydro_Bondi.c 
   @date      Wed Jan 13 13:00:49 EST 2010
   @author    Scott C. Noble
   @desc 
   Hydro initial data for the relativistic Bondi solution about 
   a single Schwarzschild black hole. 
   @enddesc 
 @@*/

/***********************************************************************************/
/***********************************************************************************/
/***********************************************************************************
   Calculates the Bondi solution, or the spherically symmetric hydrostationary 
   solution to a fluid on a static fixed background spacetime. We assume that one can
   calculate a radius "r" from the grid and that with respect to this radial coordinate, 
   the solution satisfies 

   d (\rho u^r) / dr    = 0 

   Assumes that the equation of state is  P = K \rho^\Gamma   and K  is set by 
   the location of the sonic point.     


 -- Implicitly assumes that there is no spin in the geometry as there is no Bondi 
    solution for spinning black holes.  If a spin is specified, a spherically symmetric 
    is still assumed but the 4-velocity is set consistently with the spinning spacetime. 

***********************************************************************************/
/***********************************************************************************/
/***********************************************************************************/


#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Parameters.h"
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
#include <assert.h>

// set to 1 to tracing output
#define LTRACE   1


/* Mnemonics: */

#define NDIM (4)  /* Number of spacetime dimensions */

/* mnemonics for dimensional indices */
#define TT      (0)     
#define RR      (1)
#define TH      (2)
#define PH      (3)

/* mnemonics for dimensional indices */
#define XX      (1)
#define YY      (2)
#define ZZ      (3)

/* mnemonics for coordinate system choice */
#define COORD_BOYERLINDQUIST (0)
#define COORD_KERRSCHILD     (1)
#define COORD_ISOTROPIC      (2)

/*  Macros:  */
#define DLOOP1     for(i=0  ;i<NDIM ;i++)
#define DLOOP2     for(i=0  ;i<NDIM ;i++) for(j=0  ;j<NDIM ;j++)

#define sincos sincos1   // Avoid name conflict with libc function
static inline void sincos(CCTK_REAL theta,
                          CCTK_REAL *restrict sth, CCTK_REAL *restrict cth)
{
  *sth = sin(theta);
  *cth = cos(theta);
}

//Newton-Raphson parameters:
#define NEWT_DIM_B        (1      )
#define MAX_NEWT_ITER_B   (30     )    /* Max. # of Newton-Raphson iterations for find_root_2D(); */
#define NEWT_TOL_B        (1.0e-15)    /* Min. of tolerance allowed for Newton-Raphson iterations */
#define MIN_NEWT_TOL_B    (1.0e-10)    /* Max. of tolerance allowed for Newton-Raphson iterations */
#define EXTRA_NEWT_ITER_B (2      )
#define SMALL_BONDI (1.e-20)

//some math helpers
#define SQR(x) ((x)*(x))
#define CUBE(x) ((x)*(x)*(x))


static CCTK_REAL  Mdot, rs, vs_sq, vs, cs_sq, cs, rhos, hs, K, Qdot, gamma_eos, r_sol;
static CCTK_REAL  M, a, asq, Msq; 
static CCTK_REAL  x_cen, y_cen, z_cen;
static unsigned short int coord_type; 


/******************************************************************************
  bl_to_ks_con():
  ----------
       -- transforms a contravariant vector in BL coordinates to KS coordinates;
 ******************************************************************************/
static void bl_to_ks_con(CCTK_REAL *x, CCTK_REAL blcon[], CCTK_REAL kscon[] )
{
  CCTK_REAL delta_m1, dtKS_drBL, dphiKS_drBL;
  
  delta_m1 = 1./( x[RR] * ( x[RR] - 2*M ) + asq );
  dtKS_drBL   = 2*M*x[RR] * delta_m1; 
  dphiKS_drBL = a * delta_m1;

  kscon[TT] = blcon[TT]  +  blcon[RR] * dtKS_drBL;
  kscon[RR] = blcon[RR];
  kscon[TH] = blcon[TH];
  kscon[PH] = blcon[PH]  +  blcon[RR] * dphiKS_drBL;
  
  return;
}

/******************************************************************************
  dxc_dxs_ks_calc():
  ----------------------
       -- calculates the transformation matrix  Lambda^\hat{a}_a  defined:

      x^\hat{a}[Cartesian]  = \Lambda^\hat{a}_a  x^a[Spherical] 

            where dxc_dxs[i][j] = \Lambda^i_j 

        for  Kerr-Schild coordinates.

 ******************************************************************************/
static void dxc_dxs_ks_calc(CCTK_REAL *x_cart, CCTK_REAL *x_spher, CCTK_REAL dxc_dxs[NDIM][NDIM] )
{
  int i, j; 
  CCTK_REAL r, th, ph; 
  CCTK_REAL sth,cth,sph,cph;

  for( i = 0 ; i < NDIM ; i++ ) {
    for( j = 0 ; j < NDIM ; j++ ) {
      dxc_dxs[j][i] = 0. ;
    } 
  }
  
  r  = x_spher[RR]; 
  th = x_spher[TH];
  ph = x_spher[PH]; 

  sincos( th, &sth , &cth ); 
  sincos( ph, &sph , &cph ); 

  dxc_dxs[TT][TT] = 1.                    ;  // dt/dt
  dxc_dxs[XX][RR] = cph * sth             ;  // dx/dr
  dxc_dxs[XX][TH] = (r*cph - a*sph) * cth ;  // dx/dtheta
  dxc_dxs[XX][PH] = -(x_cart[YY] - y_cen) ;  // dx/dphi
  dxc_dxs[YY][RR] = sph * sth             ;  // dy/dr
  dxc_dxs[YY][TH] = (r*sph + a*cph) * cth ;  // dy/dtheta
  dxc_dxs[YY][PH] = x_cart[XX] - x_cen    ;  // dy/dphi
  dxc_dxs[ZZ][RR] = cth                   ;  // dz/dr
  dxc_dxs[ZZ][TH] = -r*sth                ;  // dz/dtheta
  //  dxc_dxs[ZZ][PH] = 0.                    ;  // dz/dphi
  
  return;

}

/******************************************************************************
  dxc_dxs_bl_calc():
  ----------------------
       -- calculates the transformation matrix  Lambda^\hat{a}_a  defined:

      x^\hat{a}[Cartesian]  = \Lambda^\hat{a}_a  x^a[Spherical] 

            where dxc_dxs[i][j] = \Lambda^i_j 

        for  Boyer-Lindquist coordinates.

 ******************************************************************************/
static void dxc_dxs_bl_calc(CCTK_REAL *x_cart, CCTK_REAL *x_spher, CCTK_REAL dxc_dxs[NDIM][NDIM] )
{
  int i, j; 
  CCTK_REAL r, th, ph, rterm, dr; 
  CCTK_REAL sth,cth,sph,cph;

  for( i = 0 ; i < NDIM ; i++ ) {
    for( j = 0 ; j < NDIM ; j++ ) {
      dxc_dxs[j][i] = 0. ;
    } 
  }
  
  r  = x_spher[RR]; 
  th = x_spher[TH];
  ph = x_spher[PH]; 

  sincos( th, &sth , &cth ); 
  sincos( ph, &sph , &cph ); 

  rterm = sqrt( r*r + asq );
  dr = r / rterm; 
  
  dxc_dxs[TT][TT] = 1.                    ;  // dt/dt
  dxc_dxs[XX][RR] = cph * sth * dr        ;  // dx/dr
  dxc_dxs[XX][TH] = rterm * cph * cth     ;  // dx/dtheta
  dxc_dxs[XX][PH] = -(x_cart[YY] - y_cen) ;  // dx/dphi
  dxc_dxs[YY][RR] = sph * sth * dr        ;  // dy/dr
  dxc_dxs[YY][TH] = rterm * sph * cth     ;  // dy/dtheta
  dxc_dxs[YY][PH] = x_cart[XX] - x_cen    ;  // dy/dphi
  dxc_dxs[ZZ][RR] = cth                   ;  // dz/dr
  dxc_dxs[ZZ][TH] = -r*sth                ;  // dz/dtheta
  //  dxc_dxs[ZZ][PH] = 0.                    ;  // dz/dphi
  
  return;

}

/******************************************************************************
  dxc_dxs_iso_calc():
  ----------------------
       -- calculates the transformation matrix  Lambda^\hat{a}_a  defined:

      x^\hat{a}[Cartesian]  = \Lambda^\hat{a}_a  x^a[Spherical] 

            where dxc_dxs[i][j] = \Lambda^i_j 

        for  "Isotropic" coordinates.

 ******************************************************************************/
static void dxc_dxs_iso_calc(CCTK_REAL *x_cart, CCTK_REAL *x_spher, CCTK_REAL dxc_dxs[NDIM][NDIM] )
{
  int i, j; 
  CCTK_REAL th, ph,r_iso;
  CCTK_REAL sth,cth,sph,cph;

  for( i = 0 ; i < NDIM ; i++ ) {
    for( j = 0 ; j < NDIM ; j++ ) {
      dxc_dxs[j][i] = 0. ;
    } 
  }

  /* BL spherical coordinates : */
  th = x_spher[TH];
  ph = x_spher[PH]; 

  r_iso = x_spher[TT];

  sincos( th, &sth , &cth ); 
  sincos( ph, &sph , &cph ); 

  dxc_dxs[TT][TT] = 1.                    ;  // dt/dt
  dxc_dxs[XX][RR] = cph * sth             ;  // dx/dr
  dxc_dxs[XX][TH] = r_iso * cph * cth     ;  // dx/dtheta
  dxc_dxs[XX][PH] = -(x_cart[YY] - y_cen) ;  // dx/dphi
  dxc_dxs[YY][RR] = sph * sth             ;  // dy/dr
  dxc_dxs[YY][TH] = r_iso * sph * cth     ;  // dy/dtheta
  dxc_dxs[YY][PH] = x_cart[XX] - x_cen    ;  // dy/dphi
  dxc_dxs[ZZ][RR] = cth                   ;  // dz/dr
  dxc_dxs[ZZ][TH] = -r_iso*sth            ;  // dz/dtheta
  //  dxc_dxs[ZZ][PH] = 0.                    ;  // dz/dphi

  return;

}

/******************************************************************************
  ks_cart_to_ks_spher_pos():
  ----------
   -- transforms the position in Cartesian KS coordinates to Spherical KS coordinates;
 ******************************************************************************/
static void ks_cart_to_ks_spher_pos(CCTK_REAL *x_cart, CCTK_REAL *x_spher)
{
  CCTK_REAL xx,yy,zz,r,t3;

  xx = x_cart[XX] - x_cen; 
  yy = x_cart[YY] - y_cen; 
  zz = x_cart[ZZ] - z_cen; 

  t3 = 0.5*(xx*xx + yy*yy + zz*zz - asq); 
  r = sqrt(   t3 + sqrt( t3*t3 + asq*zz*zz )  );

  x_spher[TT] = x_cart[TT];
  x_spher[RR] = r; 
  x_spher[TH] = acos(zz / r); 
  t3 = atan2( (yy*r - xx*a) , (xx*r + yy*a) ); 
  if( t3 < 0. ) {  t3 += 2.*M_PI; } 
  x_spher[PH] = t3;

  return;
}

/******************************************************************************
  bl_cart_to_bl_spher_pos():
  ----------
   -- transforms the position in Cartesian BL coordinates to Spherical BL coordinates;
 ******************************************************************************/
static void bl_cart_to_bl_spher_pos(CCTK_REAL *x_cart, CCTK_REAL *x_spher)
{
  CCTK_REAL xx,yy,zz,r,t3;

  xx = x_cart[XX] - x_cen; 
  yy = x_cart[YY] - y_cen; 
  zz = x_cart[ZZ] - z_cen; 

  t3 = 0.5*(xx*xx + yy*yy + zz*zz - asq); 
  r = sqrt(   t3 + sqrt( t3*t3 + asq*zz*zz )  );

  x_spher[TT] = x_cart[TT];
  x_spher[RR] = r; 
  x_spher[TH] = acos(zz / r); 
  t3 = atan2( yy , xx ); 
  if( t3 < 0. ) {  t3 += 2.*M_PI; } 
  x_spher[PH] = t3;

  return;
}

/******************************************************************************
  iso_cart_to_bl_spher_pos():
  ----------
   -- transforms the position in Cartesian "Isotropic" coordinates to Spherical BL coordinates;
   -- r^2  =  x^2 + y^2 + z^2 in these coordinates, so they are slightly distorted from flatspace
 ******************************************************************************/
static void iso_cart_to_bl_spher_pos(CCTK_REAL *x_cart, CCTK_REAL *x_spher)
{
  CCTK_REAL xx,yy,zz,riso,r,t3;

  xx = x_cart[XX] - x_cen; 
  yy = x_cart[YY] - y_cen; 
  zz = x_cart[ZZ] - z_cen; 
 
  riso = sqrt(xx*xx + yy*yy + zz*zz);
  r = 0.25 * ( 2.*riso + M + a ) * ( 2.*riso + M - a ) / riso ; 

  x_spher[TT] = riso;
  x_spher[RR] = r; 
  x_spher[TH] = acos(zz / riso); 
  t3 = atan2( yy , xx ); 
  if( t3 < 0. ) {  t3 += 2.*M_PI; } 
  x_spher[PH] = t3;

  return;
}

/****************************************************************************
  setutcon():
 ------------
     -- find the contravariant time-component of a time-like vector 
        pointing forward in time;
****************************************************************************/
static void setutcon(CCTK_REAL *vcon, CCTK_REAL gcov[][NDIM])
{
  CCTK_REAL d,b,c;
  
  d=gcov[TT][TT];

  b = gcov[TT][1]*vcon[1] + gcov[TT][2]*vcon[2] + gcov[TT][3]*vcon[3] ;

  c = gcov[1][1] * vcon[1] * vcon[1] 
    + gcov[2][2] * vcon[2] * vcon[2] 
    + gcov[3][3] * vcon[3] * vcon[3] 
    + 2.*(   gcov[1][2] * vcon[1] * vcon[2] 
	   + gcov[1][3] * vcon[1] * vcon[3] 
           + gcov[2][3] * vcon[2] * vcon[3] );

  c += 1. ;  /* vector is timelike */

  vcon[0]=(-b-sqrt(b*b-d*c))/(d);   /* sign for pointing forward in time */

  return;
}

/****************************************************************************
  bl_gcov_func():
  ---------------
     -- Covariant Kerr metric in Boyer-Lindquist coordinates. 
****************************************************************************/
static void bl_gcov_func( CCTK_REAL *x, CCTK_REAL gcov[NDIM][NDIM])
{
  int i,j ;
  CCTK_REAL sth,cth,s2,r2,DD,mu ;
  CCTK_REAL r,th;

  for( i = 0 ; i < NDIM ; i++ ) {
    for( j = 0 ; j < NDIM ; j++ ) {
      gcov[i][j] = 0. ;
    } 
  }

  r  = x[RR];
  th = x[TH];
  sincos( th, &sth , &cth );   

  s2 = sth*sth ;
  r2 = r*r ;
  DD = 1. - 2.*M/r + asq/r2 ;
  mu = 1. + asq*cth*cth/r2 ;
	
  gcov[TT][TT] = -(1. - 2.*M/(r*mu)) ;
  gcov[TT][3] = -2.*M*a*s2/(r*mu) ;
  gcov[3][TT] = gcov[TT][3] ;
  gcov[1][1] = mu/DD ;
  gcov[2][2] = r2*mu ;
  gcov[3][3] = r2*s2*(1. + asq/r2 + 2.*M*asq*s2/(r2*r*mu)) ;

  return;
}


/***************************************************************************

 set_bondi_parameters():
 ---------------------
   -- finds the values of the hydro. quantities  at the sonic point, which
         serves as a reference point for the conservation equations given 
         in Shapiro and Teukolsky equations (G.21,G.22).  

   -- The sonic point values are then used in find_bondi_solution() to determine
       the hydro. quantities at an arbitrary radius;

   -- the "boundary conditions" that uniquely determine the Bondi solution
       are the radius of the sonic point, "rs",  and the mass accretion rate, 
       Mdot;

   -- the Bondi solution here in is the isentropic, spherically symmetric, 
       perfect fluid solution to Einstein's equations.  That is, we only 
       assume an r-dependence, there's a in-going radial velocity only, 
       and the EOS are :  P = (G-1)*rho*eps   and   P = K rho^G  
       where  K = const.  and  G is the adiabatic constant "gam".  

***************************************************************************/
static void set_bondi_parameters( CCTK_REAL M_in, CCTK_REAL Mdot_in,  CCTK_REAL rs_in, CCTK_REAL gam )
{

  CCTK_REAL  gtemp; 
  static int first_call = 1;

  /* Set the solution-determining parameters:    */
  M    = M_in;
  Mdot = Mdot_in;
  Msq  = M*M;
  rs   = rs_in;
  gamma_eos = gam;

  
  /* Calculate the hydro. quantities: */
  cs_sq  =  M / ( 2.*rs - 3.*M ) ; 

  if( cs_sq > (gam - 1.) ) { 
    cs_sq = gam - 1.;
    rs = 0.5 * M * ( 3. + 1./cs_sq ) ;
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"set_bondi_parameters(): bad value of rs, need to increase it !! \n"); 
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"set_bondi_parameters(): Need to change rs !! \n"); 
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"set_bondi_parameters(): rs[old] = %28.15e    rs[new] = %28.16e  \n\n",rs_in,rs); 
  }

  cs     =  sqrt(cs_sq);
  vs_sq  =  M / ( 2. * rs ) ; 
  vs     =  sqrt(vs_sq); 
  rhos   =  Mdot / ( 4. * M_PI * vs * rs * rs ) ; 
  gtemp  =  gam - 1.;
  hs     =  1. / ( 1. - cs_sq / (gam - 1.) );
  K      = hs * cs_sq * pow( rhos, (-gtemp) ) / gam ; 
  Qdot   = hs * hs * ( 1. - 3. * vs_sq ) ;
  gamma_eos = gam;

  if( first_call ) {
    CCTK_VInfo(CCTK_THORNSTRING,"#######################################################");         
    CCTK_VInfo(CCTK_THORNSTRING,"Bondi Solution Parameters1: ");					  
    CCTK_VInfo(CCTK_THORNSTRING,"-------------------------");					  
    CCTK_VInfo(CCTK_THORNSTRING,"M  = %28.20e     Mdot = %28.20e     rs   = %28.20e",M,Mdot,rs);	  
    CCTK_VInfo(CCTK_THORNSTRING,"vs = %28.20e     cs   = %28.20e     rhos = %28.20e",vs,cs,rhos);	  
    CCTK_VInfo(CCTK_THORNSTRING,"hs = %28.20e     K    = %28.20e     Qdot = %28.20e",hs,K,Qdot);	  
    CCTK_VInfo(CCTK_THORNSTRING,"gam= %28.20e     r_sol= %28.20e",gamma_eos, r_sol);		  
    CCTK_VInfo(CCTK_THORNSTRING,"#######################################################");	  
    first_call = 0;
  }

  return;
  
}

/**********************************************************************/
/************************************************************

  gnr_bondi():
  -----------
    -- should be just like the routine general_newton_raphson() in utoprim*.c 
       except the "physicality" condition is different;

    -- performs Newton-Rapshon method on an arbitrary system
        though tailored to calculate  rho  second Bondi Conservation eq. 
        by ensuring that  rho > 0    (look near "METHOD specific:")

    -- inspired in part by Num. Rec.'s routine newt();

    Arguements: 

       -- x[]   = set of independent variables to solve for;
       -- n     = number of independent variables and residuals;
       -- funcd = name of function that calculates residuals, etc.;

*****************************************************************/
static int gnr_bondi( CCTK_REAL x[], int n, 
	       void (*funcd) (CCTK_REAL [], CCTK_REAL [], CCTK_REAL [], 
			      CCTK_REAL [][NEWT_DIM_B], CCTK_REAL *, 
			      CCTK_REAL *, int) )
{
  CCTK_REAL f, df, dx[NEWT_DIM_B], resid[NEWT_DIM_B], 
    jac[NEWT_DIM_B][NEWT_DIM_B];
  CCTK_REAL errx;
  int    n_iter, id, i_extra, doing_extra;

  int   keep_iterating;


  // Initialize various parameters and variables:
  errx = 1. ; 
  df = f = 1.;
  i_extra = doing_extra = 0;

  n_iter = 0;


  /* Start the Newton-Raphson iterations : */
  keep_iterating = 1;
  while( keep_iterating ) { 

    (*funcd) (x, dx, resid, jac, &f, &df, n);  /* returns with new dx, f, df */

    errx = 0.;

    /* don't use line search : */
    for( id = 0; id < n ; id++) {
      x[id] += dx[id]  ;
    }

    /****************************************/
    /* Calculate the convergence criterion */
    /****************************************/

    /* For the new criterion, always look at relative error in indep. variable: */
    // METHOD specific:
    errx  = (x[0]==0.) ?  fabs(dx[0]) : fabs(dx[0]/x[0]);


    /****************************************/
    /* Make sure that the new x[] is physical : */
    /****************************************/
    x[0] = (x[0] == 0.) ? (SMALL_BONDI)  :  fabs(x[0]);
    

    /*****************************************************************************/
    /* If we've reached the tolerance level, then just do a few extra iterations */
    /*  before stopping                                                          */
    /*****************************************************************************/
    
    if( (fabs(errx) <= NEWT_TOL_B) && (doing_extra == 0) && (EXTRA_NEWT_ITER_B > 0) ) {
      doing_extra = 1;
    }

    if( doing_extra == 1 ) i_extra++ ;

    if( ((fabs(errx) <= NEWT_TOL_B)&&(doing_extra == 0)) || 
	(i_extra > EXTRA_NEWT_ITER_B) || (n_iter >= (MAX_NEWT_ITER_B-1)) ) {
      keep_iterating = 0;
    }

    n_iter++;

  }   // END of while(keep_iterating)


  /*  Check for bad untrapped divergences : */
  if( (finite(f)==0) || (finite(df)==0)  ) {
    return(2);
  }


  if( fabs(errx) > MIN_NEWT_TOL_B){
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"newt: errx = %28.20e \n", errx); 
    return(1);
  }
  if( (fabs(errx) <= MIN_NEWT_TOL_B) && (fabs(errx) > NEWT_TOL_B) ){
    return(0);
  }
  if( fabs(errx) <= NEWT_TOL_B ){
    return(0);
  }

  return(0);

}

/******************************************************************************/
/******************************************************************************

 bondi_resid():
 --------------
     -- routine to calculate the residual and jacobian used by 
           the Newton-Raphson routine general_newton_raphson(), which is 
           used to find X2 from theta;

***********************************************************************************/
static void bondi_resid(CCTK_REAL x[], CCTK_REAL dx[], CCTK_REAL resid[], CCTK_REAL jac[][NEWT_DIM_B], 
               CCTK_REAL *f, CCTK_REAL *df, int n )
{
  CCTK_REAL v, vp, h, hp, term;

  hp  =  K * gamma_eos * pow( x[0], (gamma_eos - 2.) );   //   dh/drho 
  h   =  1. +  hp * x[0] / ( gamma_eos - 1. ); 
  v   =  Mdot / ( 4. * M_PI * r_sol * r_sol * x[0] );    
  vp  =  -v / x[0];   //  dv/drho
  term = 1. - 2.*M/r_sol + v*v;
  resid[0]  =  -Qdot  +  h * h * term;
  jac[0][0] =  2. * h *( hp*term + h*v*vp );
  dx[0] = -resid[0] / jac[0][0];
  *f = 0.5*resid[0]*resid[0];
  *df = -2. * (*f);

  return;

}


/***************************************************************************/
/***************************************************************************

 find_bondi_solution():
 ---------------------

   -- essentially just calls gnr_bondi() to find the solution for
      the density at a given radius, given the parameters calculated from 
      set_bondi_parameters();

   -- after the density is found, the density (rho), internal energy densit (u), magnitude 
        of the radial component of the 4-velocity (v) are returned to the calling 
        routine; 

   -- requires r = radius at which we want solution

   -- note that v is a magnitude, so the user will have to set u^r = -v ;

   -- if there is an error in finding the solution, it returns the error 
       status from the root-finding routine.  See documentation of the 
       gnr_bondi() for further details;

***************************************************************************/
static int find_bondi_solution( CCTK_REAL r, CCTK_REAL *rho, CCTK_REAL *u, CCTK_REAL *v )
{

  int  retval=0;
  const int  ntries = 10000;
  int  itry;

  CCTK_REAL rhotmp;
  CCTK_REAL dr,ur;

  
  /************************************************************************/
  /* Find the initial guess for the newton iterations:                    */
  /* Take the sonic point values if we have no better guess (when rho<0)  */
  /************************************************************************/

  if( *rho < 0. ) {  
    if( r > 0.9*rs && r < 1.1*rs ) { 
      *rho = rhos;
    }
    else { 
      //  rhotmp = (sqrt(Qdot) - 1.) * (gamma_eos - 1.) / ( gamma_eos * K );
      if(r < rs) {  ur = pow(r,-0.5)     ;  }
      else       {  ur = 0.5*pow(r,-1.5) ;  }
      *rho = Mdot / (4.*M_PI * r * r * ur); 
    }
  } 

  // set global variables needed by residual function:
  r_sol = r ; 


  // Use Newton's method to find rho:
  retval = gnr_bondi( rho, NEWT_DIM_B, bondi_resid);     


  // If we were unsure about the guess and solver fails, then creep from known solution to desired point:
  if( retval ) { 

    dr = (r - rs)/(1.*(ntries-1));
    
    *rho = rhos;   // start with sonic point value and near sonic point

    // go gradually away from sonic point toward location where we want the solution:
    r_sol = rs ;
    for( itry = 1; itry < ntries; itry++ ) { 
      r_sol  += dr;

      retval = gnr_bondi( rho, NEWT_DIM_B, bondi_resid);     

      if( retval ) { 
	CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"find_bondi_solution: Incr. guess failed, decrease dfactor, retval = %d, r = %g, itry = %d \n", retval, r, itry);
	return(10);
      }
    }
    
    // No try where we want the solution:
    r_sol = r ; 
    retval = gnr_bondi( rho, NEWT_DIM_B, bondi_resid );  

    if( retval ) { 
      CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"find_bondi_solution: Final Incr. guess failed, decrease dfactor??, retval = %d \n", retval);
      return(11);
    }

  }

  rhotmp = *rho;

  // Calculate other quantities:
  *u = K * pow( rhotmp, gamma_eos ) / (gamma_eos - 1.);

  *v = Mdot / ( 4. * M_PI * r * r * rhotmp );

  if( *u <= 0. ) { retval = -1; } 

  return( retval ) ;

}  

/***********************************************************************************/
/***********************************************************************************
  calc_b_bondi():
  ---------
   -- calculates the contravariant magnetic vector Bcons from the amplitude of the 
        radial component of the contravariant magnetic field vector Boyer-Lindquist coordinates.  

***********************************************************************************/
#if 0
static void  calc_b_bondi( CCTK_REAL B0, CCTK_REAL vtmp, CCTK_REAL x[NDIM], CCTK_REAL x_spher[NDIM],  CCTK_REAL bcon[NDIM] )
{
  int i,j;
  CCTK_REAL  bcon_bl[NDIM] = {0.}; // F^{ab} = (b^a u^b - b^b u^a)
  CCTK_REAL  bcon_ks[NDIM];
  CCTK_REAL  gcov[NDIM][NDIM];
  CCTK_REAL  r_iso;
  CCTK_REAL dxc_dxs[NDIM][NDIM];
  CCTK_REAL f_bl = 1. - 2*M/x[RR];
  CCTK_REAL sqrt_detg_bl = SQR(x[RR])*sin(x[TH])/sqrt(f_bl);
  CCTK_REAL lapse_bl = sqrt(f_bl);

  CCTK_REAL  ucon_bl[NDIM] = {0.};
  CCTK_REAL  w_lorentz_bl; // Lorentz factor in Boyer-Lindquist coords

  assert(a == 0.);

  ucon_bl[RR] = -vtmp;

  /* Find time component of 4-velocity: */
  bl_gcov_func( x_spher, gcov );
  setutcon( ucon_bl, gcov );
  w_lorentz_bl = lapse_bl*ucon_bl[TT];

  /* Find time component of 4-velocity: */
  bcon_bl[RR] = B0*SQR(M)*w_lorentz_bl/sqrt_detg_bl;                                // -- " --
  bcon_bl[TT] = -gcov[RR][RR]/gcov[TT][TT] * bcon_bl[RR] * ucon_bl[RR]/ucon_bl[TT]; // Equ A16 of Villiers&Hawley (corrected)

  switch( coord_type ) {
  
  case COORD_BOYERLINDQUIST :
    dxc_dxs_bl_calc(x, x_spher, dxc_dxs );
    DLOOP1 { bcon[i] = 0.; } 
    DLOOP2 { bcon[i] += dxc_dxs[i][j] * bcon_bl[j] ; }
    break;


  case COORD_KERRSCHILD    :
    bl_to_ks_con(x_spher,bcon_bl,bcon_ks); 
    dxc_dxs_ks_calc(x, x_spher, dxc_dxs );
    DLOOP1 { bcon[i] = 0.; } 
    DLOOP2 { bcon[i] += dxc_dxs[i][j] * bcon_ks[j] ; }
    break;


  case COORD_ISOTROPIC     :
    r_iso = x_spher[TT]; 
    bcon_bl[RR] /=  1. + 0.25 * (asq-Msq) / (r_iso*r_iso)  ;    /* BL to Isotropic coordinate transformation */
    /* I believe we can use BL's cartesian transformation, while using BL's radius : */
    dxc_dxs_iso_calc(x, x_spher, dxc_dxs );
    DLOOP1 { bcon[i] = 0.; } 
    DLOOP2 { bcon[i] += dxc_dxs[i][j] * bcon_bl[j] ; }
    break; 

  }
  
  return;
}
#endif
static void  calc_b_bondi( CCTK_REAL B0, CCTK_REAL vtmp, CCTK_REAL x[NDIM], CCTK_REAL x_spher[NDIM],  CCTK_REAL ucon[NDIM], CCTK_REAL bcon[NDIM])
{
  int i,j;
  CCTK_REAL  bcon_spher[NDIM] = {0.}; // F^{ab} = (b^a u^b - b^b u^a)
  CCTK_REAL  ucon_spher[NDIM] = {0.};
  CCTK_REAL dxc_dxs[NDIM][NDIM];

  assert(a == 0.);
  assert(coord_type == COORD_KERRSCHILD);

  // Schwarzschild and spherical Kerr-Schild (Anil's Eddington coords) ^r components are identical
  ucon_spher[RR] = -vtmp;
  ucon_spher[TT] = (x_spher[RR] + (x_spher[RR]+2*M) * SQR(ucon_spher[RR])) / ( sqrt( (x_spher[RR]-2*M+x_spher[RR]*SQR(ucon_spher[RR]))*x_spher[RR] ) - 2*M*ucon_spher[RR] );

  // Schwarzschild and Kerr-Schild ^t components differ since t_KS = t_SW + 2*M*ln(r/(2*M)-1)
  // NB: we remove the sin(theta) factor from detg_BL  since it factors out of the divergence operator 
  bcon_spher[RR] = B0*SQR(M)/SQR(x_spher[RR]) *  // Equ A16 of Villiers&Hawley plus explict compuation of detg_BL and W_BL
                   sqrt(1-2*M/x_spher[RR] + SQR(ucon_spher[RR]));
  bcon_spher[TT] = B0*SQR(M)/SQR(x_spher[RR]) * 
                   (4*SQR(M) - SQR(ucon_spher[RR])*(SQR(x_spher[RR]+2*M*x_spher[RR]))) / 
                   (2*M*sqrt(SQR(x_spher[RR])-2*M*x_spher[RR]+SQR(x_spher[RR]*ucon_spher[RR])) - 
                    ucon_spher[RR]*SQR(x_spher[RR]));

  dxc_dxs_ks_calc(x, x_spher, dxc_dxs );

  DLOOP1 { bcon[i] = 0.; } 
  DLOOP2 { bcon[i] += dxc_dxs[i][j] * bcon_spher[j] ; }

  DLOOP1 { ucon[i] = 0.; } 
  DLOOP2 { ucon[i] += dxc_dxs[i][j] * ucon_spher[j] ; }

  return;
}

/***********************************************************************************/
/***********************************************************************************
  calc_vel_bondi():
  ---------
   -- calculates the 4-velocity from the amplitude of the 
        radial component of the 4-velocity in Boyer-Lindquist coordinates.  

***********************************************************************************/
#if 0
static void  calc_vel_bondi( CCTK_REAL vtmp, CCTK_REAL x[NDIM], CCTK_REAL x_spher[NDIM],  CCTK_REAL ucon[NDIM] )
{
  int i,j;
  CCTK_REAL  ucon_bl[NDIM] = {0.};
  CCTK_REAL  ucon_ks[NDIM];
  CCTK_REAL  gcov[NDIM][NDIM];
  CCTK_REAL  r_iso;
  CCTK_REAL dxc_dxs[NDIM][NDIM];

  ucon_bl[RR] = -vtmp;

  /* Find time component of 4-velocity: */
  bl_gcov_func( x_spher, gcov );      
  setutcon( ucon_bl, gcov );


  switch( coord_type ) {
  
  case COORD_BOYERLINDQUIST :
    dxc_dxs_bl_calc(x, x_spher, dxc_dxs );
    DLOOP1 { ucon[i] = 0.; } 
    DLOOP2 { ucon[i] += dxc_dxs[i][j] * ucon_bl[j] ; }
    break;


  case COORD_KERRSCHILD    :
    bl_to_ks_con(x_spher,ucon_bl,ucon_ks); 
    dxc_dxs_ks_calc(x, x_spher, dxc_dxs );
    DLOOP1 { ucon[i] = 0.; } 
    DLOOP2 { ucon[i] += dxc_dxs[i][j] * ucon_ks[j] ; }
    break;


  case COORD_ISOTROPIC     :
    r_iso = x_spher[TT]; 
    ucon_bl[RR] /=  1. + 0.25 * (asq-Msq) / (r_iso*r_iso)  ;    /* BL to Isotropic coordinate transformation */
    /* I believe we can use BL's cartesian transformation, while using BL's radius : */
    dxc_dxs_iso_calc(x, x_spher, dxc_dxs );
    DLOOP1 { ucon[i] = 0.; } 
    DLOOP2 { ucon[i] += dxc_dxs[i][j] * ucon_bl[j] ; }
    break; 

  default:
    assert(0 && "Internal error");
    return; /* NOTREACHED */

  }
  
  return;
}
#endif

/***********************************************************************************/
/***********************************************************************************
  GRHydro_BondiM(): 
  ---------
   -- driver routine for the Bondi solution;

***********************************************************************************/
static void GRHydro_BondiM_Internal(CCTK_ARGUMENTS, 
  CCTK_REAL range_min, CCTK_REAL range_max, 
  const int range_imin[], const int range_imax[]);

void GRHydro_BondiM(CCTK_ARGUMENTS)
{
  DECLARE_CCTK_ARGUMENTS;
  const int null[3] = {0,0,0};
  GRHydro_BondiM_Internal(CCTK_PASS_CTOC, 1e100, -1e100, cctk_lsh, null);
}

void GRHydro_BondiM_Range(CCTK_ARGUMENTS)
{
  DECLARE_CCTK_PARAMETERS;
  DECLARE_CCTK_ARGUMENTS;
  const int null[3] = {0,0,0};
  GRHydro_BondiM_Internal(CCTK_PASS_CTOC, bondi_freeze_inner_radius,
                          bondi_freeze_outer_radius,
                          cctk_lsh, null);
}

void GRHydro_BondiM_Boundary(CCTK_ARGUMENTS)
{
  DECLARE_CCTK_PARAMETERS;
  DECLARE_CCTK_ARGUMENTS;
  const int imax[3] = {cctk_lsh[0]-cctk_nghostzones[0],
                       cctk_lsh[1]-cctk_nghostzones[1],
                       cctk_lsh[2]-cctk_nghostzones[2]};
  GRHydro_BondiM_Internal(CCTK_PASS_CTOC, 1e100, -1e100, 
                          cctk_nghostzones, imax);
}

static void GRHydro_BondiM_Internal(CCTK_ARGUMENTS, 
  CCTK_REAL range_min, CCTK_REAL range_max,
  const int range_imin[], const int range_imax[])
{
  DECLARE_CCTK_ARGUMENTS;
  DECLARE_CCTK_PARAMETERS;
  CCTK_REAL det, inv_alp;
  CCTK_REAL rhotmp, utmp, vtmp, rspher, xpos[NDIM], x_spher[NDIM], ucon[NDIM], bcon[NDIM];
  int retval;
  CCTK_REAL  *r_bondi, *logr_bondi, *rho_bondi, *u_bondi, *v_bondi;
  CCTK_REAL  dlogr,logrmin;
  CCTK_REAL  rmin_bondi,rmax_bondi;
  int bvec_method;
  enum {BVEC_DIRECT, BVEC_TRANSFORM};

  int nbondi; 
  
  const int size = cctk_ash[0] * cctk_ash[1] * cctk_ash[2];
  int i, imin, j;

#    define velx(i_)  vel[i_ + 0*size]
#    define vely(i_)  vel[i_ + 1*size]
#    define velz(i_)  vel[i_ + 2*size]
#    define   sx(i_) scon[i_ + 0*size]
#    define   sy(i_) scon[i_ + 1*size]
#    define   sz(i_) scon[i_ + 2*size]
#    define Bconsx(i_) Bcons[i_ + 0*size]
#    define Bconsy(i_) Bcons[i_ + 1*size]
#    define Bconsz(i_) Bcons[i_ + 2*size]
#    define Bvecx(i_) Bvec[i_ + 0*size]
#    define Bvecy(i_) Bvec[i_ + 1*size]
#    define Bvecz(i_) Bvec[i_ + 2*size]

  if( CCTK_EQUALS(bondi_coordinates,"Boyer-Lindquist") ) { 
    coord_type = COORD_BOYERLINDQUIST ;
  } else if( CCTK_EQUALS(bondi_coordinates,"Kerr-Schild") ) { 
    coord_type = COORD_KERRSCHILD  ;
  } else if( CCTK_EQUALS(bondi_coordinates,"Isotropic") ) { 
    coord_type = COORD_ISOTROPIC ;
  } else {
    CCTK_VWarn(CCTK_WARN_ABORT, __LINE__, __FILE__, CCTK_THORNSTRING,
               "Unknown coordinate type '%s'", bondi_coordinates);
  }

  if( CCTK_EQUALS(bondi_Bvec_method, "direct")) {
    bvec_method = BVEC_DIRECT;
  } else if( CCTK_EQUALS(bondi_Bvec_method, "transform")) {
    bvec_method = BVEC_TRANSFORM;
  } else {
    CCTK_VError(__LINE__, __FILE__, CCTK_THORNSTRING,
               "Unknown bvec setup method '%s'", bondi_Bvec_method);
  }



  /* xyz location of the black hole : */
  i = 0; 
  x_cen = bh_bondi_pos_x[i] ; 
  y_cen = bh_bondi_pos_y[i] ; 
  z_cen = bh_bondi_pos_z[i] ; 

  M      = bondi_central_mass[i];
  a      = M*bondi_central_spin[i];
  asq    = a * a; 
  rmin_bondi = M * bondi_rmin[i];
  rmax_bondi = M * bondi_rmax[i];

  nbondi = n_bondi_pts[i];

  set_bondi_parameters( M, mdot_sonicpt_bondi, r_sonicpt_bondi, gl_gamma);


#if(LTRACE)
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\n##################################################\n");                       
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"  Geometry PARAMETERS \n------------------------------------\n");		  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  M           =  %28.18e \n",M       ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  a           =  %28.18e \n",a       ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  x_cen       =  %28.18e \n",x_cen   ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  y_cen       =  %28.18e \n",y_cen   ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  z_cen       =  %28.18e \n",z_cen   ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  rmin_bondi  =  %28.18e \n",rmin_bondi   ); 				  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  rmax_bondi  =  %28.18e \n",rmax_bondi   ); 				  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  nbondi      =  %d      \n",nbondi   ); 					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\n------------------------------------\n");					  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"   SOLUTION PARAMETERS \n------------------------------------\n");		  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  bondi_coordinates          =  %s      \n",bondi_coordinates ); 		  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  mdot_sonicpt_bondi         =  %28.18e \n",mdot_sonicpt_bondi); 		  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  r_sonicpt_bondi            =  %28.18e \n",r_sonicpt_bondi   ); 		  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\t  gl_gamma    =  %28.18e \n",gl_gamma     ); 	  
  CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"\n------------------------------------\n");					  
#endif

  if( r_sonicpt_bondi < rmin_bondi ) { 
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"sonic point lies below solution domain!!");
  }

  if( r_sonicpt_bondi > rmax_bondi ) { 
    CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"sonic point lies beyond solution domain!!");
  }


  /*********************************************************************************
     ARRAY ALLOCATIONS :
  *********************************************************************************/
  /* global solution : */
  if( (r_bondi = (CCTK_REAL *) calloc(nbondi, sizeof(CCTK_REAL))) == NULL ) { 
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc r_bondi \n");
    return;
  }
  if( (logr_bondi = (CCTK_REAL *) calloc(nbondi, sizeof(CCTK_REAL))) == NULL ) { 
    free(r_bondi);    
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc logr_bondi \n");
    return;
  }
  if( (rho_bondi = (CCTK_REAL *) calloc(nbondi, sizeof(CCTK_REAL))) == NULL ) { 
    free(r_bondi);    free(logr_bondi);
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc rho_bondi \n");
    return;
  }
  if( (u_bondi = (CCTK_REAL *) calloc(nbondi, sizeof(CCTK_REAL))) == NULL ) { 
    free(r_bondi);    free(logr_bondi);    free(rho_bondi);
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc u_bondi \n");
    return;
  }
  if( (v_bondi = (CCTK_REAL *) calloc(nbondi, sizeof(CCTK_REAL))) == NULL ) { 
    free(r_bondi);    free(logr_bondi);    free(rho_bondi);    free(u_bondi);
    CCTK_WARN(CCTK_WARN_ABORT,"Cannot alloc v_bondi \n");
    return;
  }
  

  /*********************************************************************************
     SOLUTION DOMAIN :
  *********************************************************************************/
  logrmin = log10(rmin_bondi);
  dlogr = (log10(rmax_bondi) - logrmin)/(1.*(nbondi-1));

  for(i=0; i < nbondi; i++) {   
    logr_bondi[i] = logrmin + dlogr*i;   
  }

  for(i=0; i < nbondi; i++) {   
    r_bondi[i] = pow(10.,logr_bondi[i]);
  }

  rhotmp = 1.e200; 
  imin = 0; 

  /* find the position in the array where the sonic point lies */
  for(i=0; i < nbondi; i++) {
    utmp = fabs(r_bondi[i] - r_sonicpt_bondi); 
    if( utmp < rhotmp ) { 
      rhotmp = utmp; 
      imin = i ; 
    }
  }

  /*********************************************************************************
     DETERMINE BONDI SOLUTION :
  *********************************************************************************/

  /* start at the sonic point (where we know the solution) and spread out from there using the 
     adjacent point as the guess for the next furthest point : */
  rhotmp = -1.;  // start with guess

  for(i=imin; i < nbondi; i++) {
    rspher = r_bondi[i]; 
    retval = find_bondi_solution( rspher, &rhotmp, &utmp, &vtmp );
    if( retval ) { 
      CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"Problem1 with find_bondi_solution() at  i = %d,  r = %28.16e \n",i,rspher);
      rhotmp = -1. ;      vtmp = 0.;       /* trigger the floor and set to staticity  */
    }
    if(rhotmp < initial_rho_abs_min)  {
      rhotmp = initial_rho_abs_min;
      utmp = K * pow( rhotmp, gl_gamma ) / (gl_gamma - 1.);
    }
    rho_bondi[i] = rhotmp;    u_bondi[i]   = utmp;     v_bondi[i]   = vtmp; 
  }

  rhotmp = -1.;  // start with guess

  for(i=imin-1; i >= 0; i--) {
    rspher = r_bondi[i]; 
    retval = find_bondi_solution( rspher, &rhotmp, &utmp, &vtmp );
    if( retval ) { 
      CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"Problem2 with find_bondi_solution() at  i = %d,  r = %28.16e \n",i,rspher);
      rhotmp = -1. ;      vtmp = 0.;       /* trigger the floor and set to staticity  */
    }
    if(rhotmp < initial_rho_abs_min)  {
      rhotmp = initial_rho_abs_min;
      utmp = K * pow( rhotmp, gl_gamma ) / (gl_gamma - 1.);
    }
    rho_bondi[i] = rhotmp;    u_bondi[i]   = utmp;     v_bondi[i]   = vtmp; 
  }

#if(LTRACE) 
  for(i=0; i < nbondi; i++) {  
    CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"radial-bondisoln %12d %26.16e %26.16e %26.16e %26.16e \n",i,r_bondi[i],rho_bondi[i],u_bondi[i],v_bondi[i]);  
  }
#endif

  /*********************************************************************************
     LOAD GRID FUNCTIONS WITH THE SOLUTION
  *********************************************************************************/
  xpos[TT] = 0.;
  
  for(int kk = 0 ; kk < cctk_lsh[2] ; kk++) {
  for(int jj = 0 ; jj < cctk_lsh[1] ; jj++) {
  for(int ii = 0 ; ii < cctk_lsh[0] ; ii++) {

    i = CCTK_GFINDEX3D(cctkGH, ii,jj,kk);

    xpos[XX] = x[i] ;
    xpos[YY] = y[i] ;
    xpos[ZZ] = z[i] ;

    if (bondi_radial_offset > 0.) {
      double rspher_orig = sqrt(SQR(xpos[XX])+SQR(xpos[YY])+SQR(xpos[ZZ]));
      double rspher_new = rspher_orig + bondi_radial_offset;
      if(rspher_orig < SMALL_BONDI) { 
        xpos[XX] = rspher_new;
        xpos[YY] = 0.;
        xpos[ZZ] = 0.;
      } else {
        for(int n = XX ; n <= ZZ ; n++) {
          xpos[n] *= rspher_new/rspher_orig;
        }
      }
    }


    switch( coord_type ) {
  
    case COORD_BOYERLINDQUIST :
      bl_cart_to_bl_spher_pos( xpos, x_spher);
      break;

    case COORD_KERRSCHILD    :
      ks_cart_to_ks_spher_pos( xpos, x_spher);
      break;

    case COORD_ISOTROPIC     :
      iso_cart_to_bl_spher_pos(xpos, x_spher); 
      break; 

    default:
      assert(0 && "Internal error");
      return; /* NOTREACHED */

    }

    rspher = x_spher[RR]; 

    // the conditions here are a bit strange. The logic goes like this:
    // range_min,range_max (and range_imin, range_imax) are radii (and indices)
    // bounding the volume where we want to evolve the fields. So during
    // evolution we only reset to ID data if we are NOT inside this volume. For
    // ID we pass special values for min/max such that these conditions never
    // trigger. 
    // TODO: do this more nicely. The fact that a comment is needed should tell
    // me that this is getting too complex.
    if(rspher > range_min && rspher < range_max)
      continue;
    if(ii >= range_imin[0] && ii < range_imax[0] &&
       jj >= range_imin[1] && jj < range_imax[1] &&
       kk >= range_imin[2] && kk < range_imax[2]) {
      continue;
    }

    /* Find nearest point in the Bondi solution : */
    j = (int)  ( 0.5 +  (log10(rspher) - logrmin) / dlogr ) ; 

    if(  j < 0  ) { 
      CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"Grid point resides outside solution domain:  %26.16e %26.16e %26.16e %26.16e %26.16e\n", rspher, rmin_bondi, xpos[XX],xpos[YY],xpos[ZZ]); 
      j = 0; 
    }
    else if( j > (nbondi - 1) ) {
      CCTK_VWarn(CCTK_WARN_DEBUG, __LINE__, __FILE__, CCTK_THORNSTRING,"GRHydro_Bondi::  Grid point resides outside solution domain:  %26.16e %26.16e %26.16e %26.16e %26.16e\n", rspher, rmin_bondi, xpos[XX],xpos[YY],xpos[ZZ]); 
      j = nbondi - 1; 
    }

    rhotmp = rho_bondi[j];
    retval = find_bondi_solution( rspher, &rhotmp, &utmp, &vtmp );
    if( retval ) { 
      CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,"Problem3 with find_bondi_solution() at  i = %d,  r = %28.16e \n",i,rspher);
      rhotmp = -1. ;      vtmp = 0.;       /* trigger the floor and set to staticity  */
    }

    if(rhotmp < initial_rho_abs_min)  {
      rhotmp = initial_rho_abs_min;
      utmp = K * pow( rhotmp, gl_gamma ) / (gl_gamma - 1.);
    }

    rho[i] = rhotmp;
    eps[i] = utmp/rhotmp;
    calc_b_bondi(bondi_bmag, vtmp, xpos, x_spher, ucon, bcon);

    // verify normaliztion of ucon
    {
      CCTK_REAL gtt = -SQR(alp[i]) +
                      gxx[i]*SQR(betax[i]) + gyy[i]*SQR(betay[i]) +
                      gzz[i]*SQR(betaz[i]) + 
                      2*gxy[i]*betax[i]*betay[i] + 2*gxz[i]*betax[i]*betaz[i] +
                      2*gyz[i]*betay[i]*betaz[i];
      CCTK_REAL gtx = gxx[i]*betax[i]+gxy[i]*betay[i]+gxz[i]*betaz[i];
      CCTK_REAL gty = gxy[i]*betax[i]+gyy[i]*betay[i]+gyz[i]*betaz[i];
      CCTK_REAL gtz = gxz[i]*betax[i]+gyz[i]*betay[i]+gzz[i]*betaz[i];
      CCTK_REAL umag = gtt*SQR(ucon[TT]) +
                       gxx[i]*SQR(ucon[XX]) + gyy[i]*SQR(ucon[YY]) + 
                       gzz[i]*SQR(ucon[ZZ]) +
                       2*(gtx*ucon[XX]*ucon[TT] + gty*ucon[YY]*ucon[TT] +
                          gtz*ucon[ZZ]*ucon[TT]) +
                       2*(gxy[i]*ucon[XX]*ucon[YY] + gxz[i]*ucon[XX]*ucon[ZZ] +
                          gyz[i]*ucon[YY]*ucon[ZZ]);
      CCTK_REAL abssum = fabs(gtt*SQR(ucon[TT])) + 
                       fabs(gxx[i]*SQR(ucon[XX])) + fabs(gyy[i]*SQR(ucon[YY])) + 
                       fabs(gzz[i]*SQR(ucon[ZZ])) +
                       2*(fabs(gtx*ucon[XX]*ucon[TT]) + fabs(gty*ucon[YY]*ucon[TT]) +
                          fabs(gtz*ucon[ZZ]*ucon[TT])) +
                       2*(fabs(gxy[i]*ucon[XX]*ucon[YY]) + fabs(gxz[i]*ucon[XX]*ucon[ZZ]) +
                          fabs(gyz[i]*ucon[YY]*ucon[ZZ]));
      if(fabs(umag-(-1.0)) > 1e-13*abssum) {
        CCTK_VWarn(CCTK_WARN_ALERT, __LINE__, __FILE__, CCTK_THORNSTRING,
                   "Suspicious four velocity (%.16e,%.16e,%.16e,%.16e) with "
                   "normalization %.16e at  i = %d x = (%g,%g,%g), r = %28.16e, "
                   "3-metric = (%.16e,%.16e,%.16e,%.16e,%.16e,%.16e) "
                   "gtt = %.16e, beta_i = (%.16e,%.16e,%.16e)",
                   ucon[TT],ucon[XX],ucon[YY],ucon[ZZ],umag,i,
                   x[i],y[i],z[i],rspher,
                   gxx[i],gxy[i],gxz[i],gyy[i],gyz[i],gzz[i],gtt,gtx,gty,gtz);
      }
    }

    inv_alp = 1./alp[i];

    velx(i) = (ucon[XX]/ucon[TT] + betax[i]) * inv_alp;
    vely(i) = (ucon[YY]/ucon[TT] + betay[i]) * inv_alp;
    velz(i) = (ucon[ZZ]/ucon[TT] + betaz[i]) * inv_alp;

    SpatialDet(gxx[i],gxy[i],gxz[i],gyy[i],gyz[i],gzz[i],&det);

    if(bvec_method == BVEC_TRANSFORM) {
      const CCTK_REAL w = ucon[TT] * alp[i];
      Bvecx(i) = w*bcon[XX] - alp[i]*bcon[TT]*ucon[XX];
      Bvecy(i) = w*bcon[YY] - alp[i]*bcon[TT]*ucon[YY];
      Bvecz(i) = w*bcon[ZZ] - alp[i]*bcon[TT]*ucon[ZZ];
    } else {
      Bvecx(i) = bondi_bmag*SQR(M)*x[i]/sqrt(det)/CUBE(r[i]);
      Bvecy(i) = bondi_bmag*SQR(M)*y[i]/sqrt(det)/CUBE(r[i]);
      Bvecz(i) = bondi_bmag*SQR(M)*z[i]/sqrt(det)/CUBE(r[i]);
    }

    // damp everything down to atmosphere inside of 1M
    if(rspher < M) {
      const CCTK_REAL smooth = 0.5*(1+tanh(tan(M_PI*(rspher/M-0.5))));
      rho[i] *= smooth;  
      velx(i) *= smooth;
      vely(i) *= smooth;
      velz(i) *= smooth;
      eps[i] *= smooth;
      Bvecx(i) *= smooth;
      Bvecy(i) *= smooth;
      Bvecz(i) *= smooth;
    }

    Prim2ConGenM(*GRHydro_eos_handle,gxx[i],gxy[i],
                 gxz[i],gyy[i],gyz[i],gzz[i],
                 det, &dens[i],&sx(i),&sy(i),&sz(i),
                 &tau[i],
                 &Bconsx(i),&Bconsy(i),&Bconsz(i),
                 rho[i],
                 velx(i),vely(i),velz(i),
                 eps[i],&press[i],
                 Bvecx(i),Bvecy(i),Bvecz(i),
                 &w_lorentz[i]);

    GRHydro_C2P_failed[i] = 0.;
    if(psidc)
      psidc[i] = 0.;
                 
  } // ii
  } // jj
  } // kk

  free(r_bondi);      free(logr_bondi);      free(rho_bondi);     free(u_bondi);   free(v_bondi);


#    undef velx
#    undef vely
#    undef velz
#    undef sx
#    undef sy
#    undef sz
#    undef Bconsx
#    undef Bconsy
#    undef Bconsz
#    undef Bvecx
#    undef Bvecy
#    undef Bvecz


  return;
}




#undef LTRACE 
#undef NEWT_DIM_B        
#undef MAX_NEWT_ITER_B   
#undef NEWT_TOL_B        
#undef MIN_NEWT_TOL_B    
#undef EXTRA_NEWT_ITER_B 
#undef SMALL_BONDI 
#undef NDIM 
#undef TT
#undef RR
#undef TH
#undef PH
#undef XX
#undef YY
#undef ZZ
#undef COORD_BOYERLINDQUIST
#undef COORD_KERRSCHILD    
#undef COORD_ISOTROPIC     
#undef DLOOP1
#undef DLOOP2

```

GRHydro_TOV.F90:
```
 /*@@
   @file      GRHydro_TOV.F90
   @date      Wed Feb 13 02:53:25 2002
   @author    Scott Hawley
   @desc 
   Initial data of the TOV type.
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"

 /*@@
   @routine    GRHydro_TOV
   @date       Sat Jan 26 02:53:49 2002
   @author     Scott Hawley
   @desc 
   Initial data for TOV stars.
   @enddesc 
   @calls     
   @calledby   
   @history 
   Alteration of the GRHydro_shockwave written by Ian Hawke
   @endhistory 

@@*/

subroutine GRHydro_TOV(CCTK_ARGUMENTS)

  implicit  none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS

  real*8   rho0
  common / com_tov / rho0
  
  integer   nr, n_succ
  integer i,j,k,nx,ny,nz
  integer CCTK_Equals
  CCTK_REAL rmax, dr
  CCTK_REAL xlb, xub
  CCTK_REAL ylb, yub
  CCTK_REAL zlb, zub
  CCTK_REAL tol
  parameter ( tol = 1e-10 )

  CCTK_REAL, allocatable, dimension (:) :: gtt, grr

  CCTK_REAL det
  integer   rc

#include "EOS_Base.inc"

#ifdef HAVE_ODEPACK
  
  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)

!-----------------------------------------------------------
! Set up the 1D spherical grid
!-----------------------------------------------------------
!   decide maximum radius to integrate out to:
!           Just use the maximum diagonal width of the grid
!  BUG: this may not be the proper procedure call
    call CCTK_CoordRange(cctkGH, xlb, xub, -1, "x", "cart3d")
    call CCTK_CoordRange(cctkGH, ylb, yub, -1, "y", "cart3d")
    call CCTK_CoordRange(cctkGH, zlb, zub, -1, "z", "cart3d")
    rmax = sqrt( (xub-xlb)**2 + (yub-ylb)**2 + (zub-zlb)**2 )

    nr = tov_nr
    dr = rmax / (nr - 1)   
    do j = 1, nr
      tov_r(j) = (j-1) * dr
    enddo

    
!-----------------------------------------------------------
!  Assign data at r=0
!-----------------------------------------------------------
    rho0 = GRHydro_rho_central
    tov_rho(1) = rho0
    tov_alpha(1) = 1.0
    tov_m(1)   = 0.0

!-----------------------------------------------------------
! Get the 1D TOV data
!-----------------------------------------------------------
      call tov_lsoda (tov_rho, tov_p, tov_m, tov_alpha, &
                tov_r,  nr, tol , n_succ, rc)

!-----------------------------------------------------------
! Handle any errors from integration routine
!-----------------------------------------------------------
   if (rc .ne. 0) then 
     call CCTK_WARN(0,"Fatal error in TOV integration")
   endif
   if (n_succ .lt. nr) then 
     call CCTK_WARN(0,"TOV integration did not extend as far out as requested")
   endif
   nr = n_succ

!-----------------------------------------------------------
! fill in additional physical info
!-----------------------------------------------------------
  do j=1,nr
!    BUG: the call looks something like this...
    tov_rho(j) = EOS_RestMassDens(GRHydro_eos_handle,tov_p(j))
  end do

!-----------------------------------------------------------
! Generate 3D data from 1D data
!  BUG: These Spin1D functions do not yet exist!
!-----------------------------------------------------------
  call Spin1D(tov_rho, tov_r, nr, rho, x, y, z, nx, ny, nz)
  call Spin1D(tov_p, tov_r, nr, press, x, y, z, nx, ny, nz)
  call Spin1D(tov_rho, tov_r, nr, eps, x, y, z, nx, ny, nz)

  allocate(grr(nr), gtt(nr))
  do i = 1, nr
     grr(i) = tov_r(i) / (tov_r(i) - 2*tov_m(i))
     gtt(i) = - tov_alpha(i)**2
  enddo
  call Spin1DMetric(tov_m, tov_r, nr, gxx, gxy, gxz, gyy, gyz, gzz, &
      x, y, z, nx, ny, nz)

  call Spin1DMetric(grr, gtt, gxx, gxy, gxz, gyy, gyz, gzz, nx, ny, nz, &
                          x, y, z, r)
  deallocate(gtt)
  deallocate(grr)

  do i=1,nx
    do j=1,ny
      do k=1,nz
          velx(i,j,k) = 0.0
          vely(i,j,k) = 0.0
          velz(i,j,k) = 0.0
          w_lorentz(i,j,k) = 1.0
      end do
    end do
  enddo

!-----------------------------------------------------------
! Set additional variables
!-----------------------------------------------------------
! Conserved Variables
  det = 1.0d0
  call prim2con(GRHydro_eos_handle,gxx, gxy, gxz, gyy, gyz, gzz, det, &
       dens, sx, sy, sz, tau, rho, &
       velx, vely, velz, eps, press, w_lorentz)

! Copy data to other time steps
  do i=1,nx
    do j=1,ny
      do k=1,nz

!        Primitive variables
         rho_p(i,j,k) = rho(i,j,k)
         press_p(i,j,k) = press(i,j,k)
         eps_p(i,j,k) = eps(i,j,k)
         velx_p(i,j,k) = velx(i,j,k)
         vely_p(i,j,k) = vely(i,j,k)
         velz_p(i,j,k) = velz(i,j,k)
         w_lorentz_p(i,j,k) = w_lorentz(i,j,k)

!        Conserved variables
         dens_p(i,j,k) = dens(i,j,k)
         tau_p(i,j,k) = tau(i,j,k)
         sx_p(i,j,k) = sx(i,j,k)
         sy_p(i,j,k) = sy(i,j,k)
         sz_p(i,j,k) = sz(i,j,k)

      end do
    end do
  end do
  
! BUG:  Why am I doing this?  
  densrhs = 0.d0
  sxrhs = 0.d0
  syrhs = 0.d0
  szrhs = 0.d0
  taurhs = 0.d0

  return
  
end subroutine GRHydro_TOV



! =======================================================================

      subroutine Spin1D(rad_func, r, nr, cart_func, x, y, z, &
                        nx, ny, nz)
!     ................................................................
!   Takes a "radial grid function" and creates a 3D grid function
!   BUG/FEATURE: This doesnt do any fancy interpolation at all!
!
      implicit none

      integer nr, nx, ny, nz
      CCTK_REAL   rad_func(nr), r(nr)
      CCTK_REAL   cart_func(nx,ny,nz),  x(nx,ny,nz), y(nx,ny,nz), z(nx,ny,nz)

      integer i,j,k, ri
      real    rloc

      do k = 1, nz
        do j = 1, ny
          do i = 1, nx

!      Given a point in 3D cartesian space, substitute next-further-out data 
!      value in 1D spherical space
              rloc = sqrt(x(i,j,k)**2 + y(i,j,k)**2 + z(i,j,k)**2)
              ri = 1
100           continue
              if (r(ri) .lt. rloc) then
                 ri = ri+1
              endif

              cart_func(i,j,k) =  rad_func(ri)
          end do
        end do
      end do

      end subroutine Spin1D



! =======================================================================


       subroutine Spin1DMetric(grr,gtt,gxx,gxy, &
          gxz,gyy,gyz,gzz,nx,ny,nz,x,y,z,r)

!     ................................................................
!     this subroutine converts spherical metric components to cartesian
!
!    This code was totally ripped off of Francisco Guzmans spheretocart
!    code.  Used with his persmission. 

      implicit NONE
      integer nx,ny,nz
      integer i,j,k

      CCTK_REAL x(nx,ny,nz),y(nx,ny,nz),z(nx,ny,nz),r(nx,ny,nz)
      CCTK_REAL grr(nx,ny,nz),gtt(nx,ny,nz)
      CCTK_REAL gxx(nx,ny,nz),gxy(nx,ny,nz),gxz(nx,ny,nz)
      CCTK_REAL gyy(nx,ny,nz),gyz(nx,ny,nz),gzz(nx,ny,nz)

      CCTK_REAL xp,yp,zp,rp

!     define derivatives drx = (dr/dx)
      CCTK_REAL drx,dry,drz
      CCTK_REAL dtx,dty,dtz
      CCTK_REAL dpx,dpy,dpz

! this equation for gxx gyy gzz assumes that the metric is diagonal
! and that grr = 1 at the origin, but should compute for all points
! including the origin and the line x=y=0.


      do k = 1, nz
         do j = 1, ny
            do i = 1, nx

               xp = x(i,j,k)
               yp = y(i,j,k)
               zp = z(i,j,k)
               rp = r(i,j,k)

               if (rp.eq.0) then

                  gxx(i,j,k) = 1.
                  gyy(i,j,k) = 1.
                  gzz(i,j,k) = 1.
                  gxy(i,j,k) = 0.
                  gxz(i,j,k) = 0.
                  gyz(i,j,k) = 0.

               else

                  gxx(i,j,k) = (xp/rp)**2 * grr(i,j,k) + &
                       (zp**2 + yp**2)/(rp**2)
                  gyy(i,j,k) = (yp/rp)**2 * grr(i,j,k) + &
                       (xp**2 + zp**2)/(rp**2)
                  gzz(i,j,k) = (zp/rp)**2 * grr(i,j,k) + &
                       (xp**2 + yp**2)/(rp**2)

                  if ((xp.eq.0) .and. (yp.eq.0)) then

                     gxy(i,j,k) = 0.
                     gyz(i,j,k) = 0.
                     gxz(i,j,k) = 0.

                  else

                     gxy(i,j,k) = (xp * yp/(rp**2) * grr(i,j,k) &
                         + (xp*yp*zp**2)/(rp**2*(xp**2+yp**2)) &
                         - (yp*xp)/(xp**2+yp**2))

                     gxz(i,j,k) = (xp * zp/(rp**2) &
                         * grr(i,j,k) - (xp * zp/(rp**2))) 

                     gyz(i,j,k) = (yp * zp/(rp**2) &
                         * grr(i,j,k) - (yp * zp/(rp**2)))

                  endif

               endif

            enddo
          enddo
        enddo
#else
        write(6,*) 'GRHydro_TOV: Does nothing.  Recompile with odepack'
#endif

      return
      end




```

GRHydro_PoloidalMagFieldM.F90:
```
 /*@@
   @file      GRHydro_PoloidalMagFieldM.F90
   @date      Oct 31, 2011
   @author    Bruno Mundim, Joshua Faber, Scott Noble
   @desc 
   Poloidal Magnetic field implemented as in "General relativistic 
simulations of magnetized binary neutron star mergers" - 
by Yuk Tung Liu, Stuart L. Shapiro, Zachariah B. Etienne, and 
Keisuke Taniguchi - Phys. Rev. D 78, 024012 (2008)  

   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)
#define Bvecx(i,j,k) Bvec(i,j,k,1)
#define Bvecy(i,j,k) Bvec(i,j,k,2)
#define Bvecz(i,j,k) Bvec(i,j,k,3)
#define Bconsx(i,j,k) Bcons(i,j,k,1)
#define Bconsy(i,j,k) Bcons(i,j,k,2)
#define Bconsz(i,j,k) Bcons(i,j,k,3)
#define Avecx(i,j,k) Avec(i,j,k,1)
#define Avecy(i,j,k) Avec(i,j,k,2)
#define Avecz(i,j,k) Avec(i,j,k,3)

 /*@@
   @routine   GRHydro_PoloidalMagFieldM
   @date      Oct 31, 2011
   @author    Bruno Mundim, Joshua Faber, Scott Noble
   @desc 
   Poloidal Magnetic field implemented as in "General relativistic 
simulations of magnetized binary neutron star mergers" - 
by Yuk Tung Liu, Stuart L. Shapiro, Zachariah B. Etienne, and 
Keisuke Taniguchi - Phys. Rev. D 78, 024012 (2008)  
   @enddesc 
   @calls     
   @calledby   
   @history 
   Using GRHydro_ShockTubeM.F90 as a template.
   @endhistory 

@@*/

subroutine GRHydro_PoloidalMagFieldM(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz, set_Avec
  CCTK_REAL :: det
  CCTK_REAL :: sdet
  CCTK_REAL :: dx,dy,dz
  CCTK_REAL :: rhofac, delPcut, maxP_Pcut
  CCTK_REAL :: AphiL, Ax, Ay, Az
  CCTK_REAL :: rho_dx, rho_dy, rho_dz
  CCTK_REAL :: press_dx, press_dy, press_dz
  CCTK_REAL :: Aphi_dx, Aphi_dy, Aphi_dz
  CCTK_REAL :: Ax_dy, Ax_dz, Ay_dx, Ay_dz

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)

  dx = CCTK_DELTA_SPACE(1)
  dy = CCTK_DELTA_SPACE(2)
  dz = CCTK_DELTA_SPACE(3)

  set_Avec = 0
  if ( CCTK_EQUALS(Bvec_evolution_method,"GRHydro_Avec") ) then
     set_Avec = 1
  end if

  write(*,*)'GRHydro_InitData: Setting up initial poloidal magnetic field'

! Initialize to zero
  Bvec = 0.0d0

  do i=2,nx-1
   do j=2,ny-1
    do k=2,nz-1

     rhofac = 1.0d0-rho(i,j,k)/poloidal_rho_max
     delPcut = press(i,j,k)-poloidal_P_cut
     maxP_Pcut = max(delPcut,0.0d0)
     AphiL = poloidal_A_b*rhofac**poloidal_n_p*maxP_Pcut**poloidal_P_p
     Ax = -y(i,j,k)*AphiL
     Ay =  x(i,j,k)*AphiL
     Az = 0.0
 
!!     write(*,*)'Before accessing rho(i,k,k)'
!!     write(*,*)'rho(',i,',',j,',',k,') = ', rho(i,j,k)
!!     write(*,*)'Ax, Ay, Az, Aphi = ', Ax, Ay, Az,AphiL
!!     write(*,*)'rhofac = ', rhofac
!!     write(*,*)'delPcut = ', delPcut
!!     write(*,*)'maxP_Pcut = ', maxP_Pcut 

#warning "This algorithm does only work on Cartesian grids!!"
     rho_dx = 0.5d0*(rho(i+1,j,k)-rho(i-1,j,k))/dx 
     rho_dy = 0.5d0*(rho(i,j+1,k)-rho(i,j-1,k))/dy 
     rho_dz = 0.5d0*(rho(i,j,k+1)-rho(i,j,k-1))/dz 
     press_dx = 0.5d0*(press(i+1,j,k)-press(i-1,j,k))/dx 
     press_dy = 0.5d0*(press(i,j+1,k)-press(i,j-1,k))/dy 
     press_dz = 0.5d0*(press(i,j,k+1)-press(i,j,k-1))/dz 

     if (maxP_Pcut > 0.0) then
       Aphi_dx = poloidal_A_b*( &
                   -poloidal_n_p*rho_dx/poloidal_rho_max*maxP_Pcut**poloidal_P_p &
                   +rhofac**poloidal_n_p*press_dx*poloidal_P_p*maxP_Pcut**(poloidal_P_p-1))
       Aphi_dy = poloidal_A_b*( &
                   -poloidal_n_p*rho_dy/poloidal_rho_max*maxP_Pcut**poloidal_P_p &
                   +rhofac**poloidal_n_p*press_dy*poloidal_P_p*maxP_Pcut**(poloidal_P_p-1))
       Aphi_dz = poloidal_A_b*( &
                   -poloidal_n_p*rho_dz/poloidal_rho_max*maxP_Pcut**poloidal_P_p &
                   +rhofac**poloidal_n_p*press_dz*poloidal_P_p*maxP_Pcut**(poloidal_P_p-1))
     else
       Aphi_dx = 0.0
       Aphi_dy = 0.0
       Aphi_dz = 0.0
     endif

     Ax_dy = -AphiL - y(i,j,k)*Aphi_dy
     Ax_dz = -y(i,j,k)*Aphi_dz
     Ay_dx = AphiL + x(i,j,k)*Aphi_dx
     Ay_dz = x(i,j,k)*Aphi_dz

           
     det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))
     sdet = sqrt(det) 
     
     Bvecx(i,j,k) = Ay_dz/sdet
     Bvecy(i,j,k) = - Ax_dz/sdet
     Bvecz(i,j,k) = (Ax_dy-Ay_dx)/sdet

     if ( set_Avec.gt.0 ) then
        Avecx(i,j,k) = Ax
        Avecy(i,j,k) = Ay
        Avecz(i,j,k) = Az
     end if

     !Bvecx(i,j,k) = 0.0d0 
     !Bvecy(i,j,k) = 0.0d0
     !Bvecz(i,j,k) = 0.00000001/sdet

           if (CCTK_EQUALS(GRHydro_eos_type,"Polytype")) then
              call Prim2ConPolyM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
                   gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
                   det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
                   tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
                   velx(i,j,k),vely(i,j,k),velz(i,j,k),&
                   eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
                   w_lorentz(i,j,k))
           else
             if (evolve_temper .ne. 0) then
               call Prim2ConGenM_hot(GRHydro_eos_handle,GRHydro_reflevel,&
                    i,j,k,x(i,j,k),y(i,j,k),z(i,j,k),gxx(i,j,k),gxy(i,j,k),&
                    gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
                    det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
                    tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
                    velx(i,j,k),vely(i,j,k),velz(i,j,k),&
                    eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
                    w_lorentz(i,j,k),temperature(i,j,k),y_e(i,j,k))
             else
               call Prim2ConGenM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
                    gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
                    det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
                    tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
                    velx(i,j,k),vely(i,j,k),velz(i,j,k),&
                    eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
                    w_lorentz(i,j,k))
             end if
           end if
           
        enddo
     enddo
  enddo
  
  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0
  Bconsrhs = 0.d0
  if (clean_divergence .ne. 0) then
    psidcrhs =0.0
  endif
  
  !Bvec = 0
  !lBvec = 0
  !Bcons = 0
  !Avec = 0
  
  return
  
end subroutine GRHydro_PoloidalMagFieldM



```

GRHydro_C2P2CM.F90:
```
 /*@@
   @file      GRHydro_C2P2CM.F90
   @date      Sep 23, 2010
   @author    Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   A test of the conservative <--> primitive variable exchange
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"


 /*@@
   @routine    c2p2cM
   @date       Sep 23, 2010
   @author     Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   Testing the conservative <--> primitive variable transformations.
   The values before and after should match.
   @enddesc 
   @calls     
   @calledby   
   @history 
 
   @endhistory 

@@*/

subroutine c2p2cM(CCTK_ARGUMENTS)


  implicit none

  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS

  CCTK_REAL :: det, sdet, invdet
  CCTK_REAL :: uxx,uxy,uxz,uyy,uyz,uzz
  CCTK_REAL :: gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send
  CCTK_REAL :: dens_send,sx_send,sy_send,sz_send,tau_send
  CCTK_REAL :: bconsx_send, bconsy_send, bconsz_send
  CCTK_REAL :: entropy_send, entropycons_send;
  CCTK_REAL :: rho_send,velx_send,vely_send,velz_send,eps_send
  CCTK_REAL :: press_send,w_lorentz_send
  CCTK_REAL :: bvcx_send, bvcy_send, bvcz_send, b2_send
  CCTK_REAL :: C2P_failed
  CCTK_REAL :: BdotB, Bdotv, b2, beta_mag
  CCTK_INT :: epsnegative

! begin EOS Omni vars
  CCTK_REAL :: pmin(1), epsmin(1), local_gam(1), epsval(1)
  CCTK_INT :: n,keytemp,anyerr,keyerr(1)
  CCTK_REAL :: xpress(1),xtemp(1),xye(1),xeps(1),xrho(1)
  n=1;keytemp=0;anyerr=0;keyerr(1)=0
  xpress(1)=0.0d0;xtemp(1)=0.0d0;xye(1)=0.0d0;xeps(1)=0.0d0
! end EOS Omni vars

  call CCTK_WARN(1,"This test works only with Ideal_Fluid EoS")
  
  gxx_send = gxx_init
  gxy_send = gxy_init
  gxz_send = gxz_init
  gyy_send = gyy_init
  gyz_send = gyz_init
  gzz_send = gzz_init
  
  det = SPATIAL_DETERMINANT(gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send)
  sdet = sqrt(det)
  invdet = 1.d0 / det
  uxx = (-gyz_send**2 + gyy_send*gzz_send)*invdet
  uxy = (gxz_send*gyz_send - gxy_send*gzz_send)*invdet
  uyy = (-gxz_send**2 + gxx_send*gzz_send)*invdet
  uxz = (-gxz_send*gyy_send + gxy_send*gyz_send)*invdet
  uyz = (gxy_send*gxz_send - gxx_send*gyz_send)*invdet
  uzz = (-gxy_send**2 + gxx_send*gyy_send)*invdet

! Initialize the velocity as GRHydro_Con2PrimM_pt may use these
! values as initial guess for its Newton-Raphson procedure.
!  velx_send = 0.1d0
!  vely_send = 0.1d0 
!  velz_send = 0.1d0
!  
!  dens_send = 1.29047362d0
!  sx_send   = 0.166666658d0
!  sy_send   = 0.166666658d0
!  sz_send   = 0.166666658d0
!  tau_send  = 0.484123939d0

  velx_send = velx_init
  vely_send = vely_init
  velz_send = velz_init

  dens_send = dens_init
  sx_send   = sx_init
  sy_send   = sy_init
  sz_send   = sz_init
  tau_send  = tau_init

  bvcx_send   = Bx_init
  bvcy_send   = By_init
  bvcz_send   = Bz_init
  bconsx_send   = sdet*Bx_init
  bconsy_send   = sdet*By_init
  bconsz_send   = sdet*Bz_init

  rho_send = rho_init
  eps_send = eps_init
  press_send = press_init
  w_lorentz_send = sqrt(1.0d0-(gxx_send*velx_send**2+gyy_send*vely_send**2+ &
                               gzz_send*velz_send**2 &
                               +2.0d0*(gxy_send*velx_send*vely_send+ &
                                       gxz_send*velx_send*velz_send+ &
                                       gyz_send*vely_send*velz_send &
                                      ) &
                               ) &
                        ) 
  w_lorentz_send = 1.0d0/w_lorentz_send


  epsnegative = 0
  
  xrho = 1.0d-10
  epsval = 1.0d0

  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,epsval,xtemp,xye,pmin,keyerr,anyerr)

  call EOS_Omni_EpsFromPress(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,xeps,xtemp,xye,pmin,epsmin,keyerr,anyerr)

  local_gam = 0.0d0
  xrho = 1.0d0
  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,epsval,xtemp,xye,local_gam,keyerr,anyerr)
  local_gam = local_gam + 1.0

  if(use_c2p_with_entropy_eqn.eq.1)then
    entropy_send = ( local_gam(1) - 1.0d0 ) * eps_send * &
                     rho_send**(2.0d0 - local_gam(1))
    entropycons_send = sdet * w_lorentz_send * entropy_send
  endif

  C2P_failed = 0.0d0

  write(*,*) 'C2P2CM test: metric values.'
  write(*,*) '    gxx: ', gxx_send
  write(*,*) '    gxy: ', gxy_send
  write(*,*) '    gxz: ', gxz_send
  write(*,*) '    gyy: ', gyy_send
  write(*,*) '    gyz: ', gyz_send
  write(*,*) '    gzz: ', gzz_send
  write(*,*) '    uxx: ', uxx
  write(*,*) '    uxy: ', uxy
  write(*,*) '    uxz: ', uxz
  write(*,*) '    uyy: ', uyy
  write(*,*) '    uyz: ', uyz
  write(*,*) '    uzz: ', uzz
  write(*,*) '    det: ', det

  write(*,*) 'C2P2CM test: initial primitive guess values.'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  if(use_c2p_with_entropy_eqn.eq.1)then
    write(*,*) '   entropy  : ',entropy_send
  endif
  write(*,*) '   W     : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  write(*,*) '   C2P_failed : ',C2P_failed

  write(*,*) 'C2P2CM test: initial values.'
  write(*,*) '   conservative variables: '
  write(*,*) '   dens: ',dens_send
  write(*,*) '   sx  : ',sx_send
  write(*,*) '   sy  : ',sy_send
  write(*,*) '   sz  : ',sz_send
  write(*,*) '   tau : ',tau_send
  write(*,*) '   Bconsx  : ',bconsx_send
  write(*,*) '   Bconsy  : ',bconsy_send
  write(*,*) '   Bconsz  : ',bconsz_send
  if(use_c2p_with_entropy_eqn.eq.1)then
    write(*,*) '   entropycons  : ',entropycons_send
  endif
  write(*,*) '   eps : ',eps_send
  write(*,*) '   W   : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send

! Is this point magnetically dominated?
   BdotB = gxx_send*bvcx_send**2+gyy_send*bvcy_send**2+gzz_send*bvcz_send**2&
     +2.0*(gxy_send*bvcx_send*bvcy_send+gxz_send*bvcx_send*bvcy_send+ &
           gyz_send*bvcy_send*bvcz_send) 
   Bdotv = gxx_send*bvcx_send*velx_send+gyy_send*bvcy_send*vely_send  &
          +gzz_send*bvcz_send*velz_send  &
          +gxy_send*(bvcx_send*vely_send+bvcy_send*velx_send)  &
          +gxz_send*(bvcx_send*velz_send+bvcz_send*velx_send)  &
          +gyz_send*(bvcy_send*velz_send+bvcz_send*vely_send)

   b2 = BdotB/w_lorentz_send**2 + Bdotv**2

   beta_mag = 2.0*press_send/b2;

  write(*,*) '   BdotB   : ',BdotB
  write(*,*) '   Bdotv   : ',Bdotv
  write(*,*) '      b2   : ',b2
  write(*,*) 'beta_mag   : ',beta_mag
  
  if(use_c2p_with_entropy_eqn.eq.0)then
     write(*,*) 'C2P2CM test: getting the associated primitive variables.'
     call Con2PrimGenM(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,local_gam(1),dens_send,sx_send,sy_send,sz_send, &
       tau_send,bconsx_send,bconsy_send,bconsz_send,xtemp(1),xye(1),rho_send,velx_send,vely_send,velz_send, &
       eps_send,press_send,bvcx_send,bvcy_send,bvcz_send,b2_send,w_lorentz_send, &
       gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,&
       uxx,uxy,uxz,uyy,uyz,uzz,det,&
       epsnegative,C2P_failed)
  else
     write(*,*) 'C2P2CMee test: getting the associated primitive variables.'
     call Con2PrimGenMee(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,local_gam(1),dens_send,sx_send,sy_send,sz_send, &
       tau_send,bconsx_send,bconsy_send,bconsz_send,entropycons_send,xtemp(1),xye(1),rho_send,velx_send,vely_send,velz_send, &
       eps_send,press_send,bvcx_send,bvcy_send,bvcz_send,b2_send,w_lorentz_send, &
       gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,&
       uxx,uxy,uxz,uyy,uyz,uzz,det,&
       epsnegative,C2P_failed)
  endif

  if(use_c2p_with_entropy_eqn.eq.1)then
    entropy_send = ( local_gam(1) - 1.0d0 ) * eps_send * &
                     rho_send**(2.0d0 - local_gam(1))
    entropycons_send = sdet * w_lorentz_send * entropy_send
  endif
  
  write(*,*) 'C2P2CM test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  if(use_c2p_with_entropy_eqn.eq.1)then
    write(*,*) '   entropy  : ',entropy_send
  endif
  write(*,*) '   W     : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  write(*,*) '   C2P_failed : ',C2P_failed
  
  write(*,*) 'C2P2CM test: converting back to conserved variables.'
  call Prim2ConGenM(GRHydro_eos_handle,gxx_send, gxy_send, gxz_send, gyy_send, gyz_send, gzz_send, det, &
       dens_send, sx_send, sy_send, sz_send, tau_send, bconsx_send, bconsy_send, bconsz_send, rho_send, &
       velx_send, vely_send, velz_send, eps_send, press_send, bvcx_send, bvcy_send, bvcz_send, w_lorentz_send) 
  
  write(*,*) 'C2P2CM test: the conserved variables are'
  write(*,*) '   conservative variables: '
  write(*,*) '   dens: ',dens_send
  write(*,*) '   sx  : ',sx_send
  write(*,*) '   sy  : ',sy_send
  write(*,*) '   sz  : ',sz_send
  write(*,*) '   tau : ',tau_send
  write(*,*) '   Bconsx  : ',bconsx_send
  write(*,*) '   Bconsy  : ',bconsy_send
  write(*,*) '   Bconsz  : ',bconsz_send
  if(use_c2p_with_entropy_eqn.eq.1)then
    write(*,*) '   entropycons  : ',entropycons_send
  endif
  write(*,*) '   eps : ',eps_send
  write(*,*) '   W   : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  STOP

  return

end subroutine c2p2cM

```

GRHydro_C2P2CM_eosomni.F90:
```
 /*@@
   @file      GRHydro_C2P2CM.F90
   @date      Sep 23, 2010
   @author    Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   A test of the conservative <--> primitive variable exchange
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"

 /*@@
   @routine    c2p2cM
   @date       Sep 23, 2010
   @author     Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   Testing the conservative <--> primitive variable transformations.
   The values before and after should match.
   @enddesc 
   @calls     
   @calledby   
   @history 
 
   @endhistory 

@@*/

subroutine c2p2cM(CCTK_ARGUMENTS)


  implicit none

  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS

  CCTK_REAL :: det
  CCTK_REAL :: uxx,uxy,uxz,uyy,uyz,uzz
  CCTK_REAL :: gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send
  CCTK_REAL :: dens_send,sx_send,sy_send,sz_send,tau_send
  CCTK_REAL :: bconsx_send, bconsy_send, bconsz_send
  CCTK_REAL :: rho_send,velx_send,vely_send,velz_send,eps_send
  CCTK_REAL :: press_send,w_lorentz_send,x_send,y_send,z_send,r_send
  CCTK_REAL :: bvcx_send, bvcy_send, bvcz_send, b2_send
  CCTK_REAL :: C2P_failed
  CCTK_INT :: epsnegative

! begin EOS Omni vars
  CCTK_REAL :: pmin(1), epsmin(1), local_gam(1), epsval(1)
  CCTK_INT :: n,keytemp,anyerr,keyerr(1)
  CCTK_REAL :: xpress(1),xtemp(1),xye(1),xeps(1),xrho(1)
  n=1;keytemp=0;anyerr=0;keyerr(1)=0
  xpress(1)=0.0d0;xtemp(1)=0.0d0;xye(1)=0.0d0;xeps(1)=0.0d0
! end EOS Omni vars

  call CCTK_WARN(1,"This test works only with Ideal_Fluid EoS")
  
  x_send = 0.0d0
  y_send = 0.0d0
  z_send = 0.0d0
  r_send = 0.0d0
  
  gxx_send = 1.0d0
  gyy_send = 1.0d0 
  gzz_send = 1.0d0
  gxy_send = 0.0d0
  gxz_send = 0.0d0
  gyz_send = 0.0d0
  
  det = 1.0d0
  
  uxx = 1.0d0
  uyy = 1.0d0 
  uzz = 1.0d0
  uxy = 0.0d0
  uxz = 0.0d0
  uyz = 0.0d0

! Initialize the velocity as GRHydro_Con2PrimM_pt may use these
! values as initial guess for its Newton-Raphson procedure.
  velx_send = 0.1d0
  vely_send = 0.1d0 
  velz_send = 0.1d0
  
  dens_send = 1.29047362d0
  sx_send   = 0.166666658d0
  sy_send   = 0.166666658d0
  sz_send   = 0.166666658d0
  tau_send  = 0.484123939d0
  
  bvcx_send   = Bx_init
  bvcy_send   = By_init
  bvcz_send   = Bz_init
  bconsx_send   = Bx_init
  bconsy_send   = By_init
  bconsz_send   = Bz_init

  eps_send = 1.0d-6
  press_send = 6.666666666666667d-7
  w_lorentz_send = 1.0d0

  epsnegative = 0
  
  xrho = 1.0d-10
  epsval = 1.0d0

  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,epsval,xtemp,xye,pmin,keyerr,anyerr)
  
  !!  call EOS_Omni_EpsFromPress(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
  !!       xrho,xeps,xtemp,xye,pmin,epsmin,keyerr,anyerr)
  call EOS_Omni_EpsFromPress(1,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,xeps,xtemp,xye,pmin,epsmin,keyerr,anyerr)

  local_gam = 0.0d0
  xrho = 1.0d0
  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,epsval,xtemp,xye,local_gam,keyerr,anyerr)
  local_gam = local_gam + 1.0

  C2P_failed = 0.0d0

  write(*,*) 'C2P2CM test: initial values.'
  write(*,*) '   conservative variables: '
  write(*,*) '   dens: ',dens_send
  write(*,*) '   sx  : ',sx_send
  write(*,*) '   sy  : ',sy_send
  write(*,*) '   sz  : ',sz_send
  write(*,*) '   tau : ',tau_send
  write(*,*) '   Bconsx  : ',bconsx_send
  write(*,*) '   Bconsy  : ',bconsy_send
  write(*,*) '   Bconsz  : ',bconsz_send
  write(*,*) '   eps : ',eps_send
  write(*,*) '   W   : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  write(*,*) 'C2P2CM test: getting the associated primitive variables.'
  call Con2PrimGenM(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,local_gam(1),dens_send,sx_send,sy_send,sz_send, &
       tau_send,bconsx_send,bconsy_send,bconsz_send,0.d0,0.d0,rho_send,velx_send,vely_send,velz_send, &
       eps_send,press_send,bvcx_send,bvcy_send,bvcz_send,b2_send,w_lorentz_send, &
       gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,&
       uxx,uxy,uxz,uyy,uyz,uzz,det,&
       epsnegative,C2P_failed)

  !!  call Con2PrimGenM(GRHydro_eos_handle,local_gam(1),dens_send,sx_send,sy_send,sz_send, &
  !!       tau_send,bconsx_send,bconsy_send,bconsz_send,rho_send,velx_send,vely_send,velz_send, &
  !!      eps_send,press_send,bvcx_send,bvcy_send,bvcz_send,b2_send,w_lorentz_send, &
  !!      gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,&
  !!       uxx,uxy,uxz,uyy,uyz,uzz,det,&
  !!      epsnegative,C2P_failed)
  
  write(*,*) 'C2P2CM test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   W     : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  write(*,*) '   C2P_failed : ',C2P_failed
  
  write(*,*) 'C2P2CM test: converting back to conserved variables.'
  call Prim2ConGenM(GRHydro_eos_handle,gxx_send, gxy_send, gxz_send, gyy_send, gyz_send, gzz_send, det, &
       dens_send, sx_send, sy_send, sz_send, tau_send, bconsx_send, bconsy_send, bconsz_send, rho_send, &
       velx_send, vely_send, velz_send, eps_send, press_send, bvcx_send, bvcy_send, bvcz_send, w_lorentz_send) 
  
  write(*,*) 'C2P2CM test: the conserved variables are'
  write(*,*) '   conservative variables: '
  write(*,*) '   dens: ',dens_send
  write(*,*) '   sx  : ',sx_send
  write(*,*) '   sy  : ',sy_send
  write(*,*) '   sz  : ',sz_send
  write(*,*) '   tau : ',tau_send
  write(*,*) '   Bconsx  : ',bconsx_send
  write(*,*) '   Bconsy  : ',bconsy_send
  write(*,*) '   Bconsz  : ',bconsz_send
  write(*,*) '   eps : ',eps_send
  write(*,*) '   W   : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  STOP

  return

end subroutine c2p2cM

```

tov_fcn.F:
```
#ifdef HAVE_ODEPACK
c------------------------------------------------------------------------
c    equation of state, converts p to rho
c      currently using a polytrope
c------------------------------------------------------------------------
      real*8  function p2rho(p)
      implicit none
      real*8 p

      p2rho = p ** (3/4.0d0)
  
      return 
      end

c------------------------------------------------------------------------
c    equation of state, converts rho to p
c      currently using a polytrope
c------------------------------------------------------------------------
      real*8  function rho2p(rho)
      implicit none
      real*8 rho

      rho2p = rho ** (4/3.0d0)
 
      return
      end


c-----------------------------------------------------------
c     Integrates static equations of motion for spherically 
c     symmetric, general-relativistic TOV star:
c
c     dp/dr = - (p + rho)*(m+4*pi*r**3*p)/ r / (r-2*m)
c     dm/dr = 4*pi*r**2 * rho
c     d alpha/dr = alpha*(m+4*pi*r**3*rho )/ r / (r-2*m)
c
c  (see, e.g. Walds textbook pp126-127.)
c  where g_tt = - alpha**2, and g_rr = 1/(1-2m/r)
c
c  Note that (my rho) = (the-rest-of-GRHydros rho)*(1+epsilon)
c
c-----------------------------------------------------------
c     neq = 3
c-----------------------------------------------------------

      subroutine tov_fcn(neq,r,y,yprime)
         implicit    none

         real*8   rho0
         common / com_tov / rho0

         real*8      p2rho

         integer     neq
         real*8      r,     y(neq),    yprime(neq)

         real*8      pi
         parameter   ( pi = 3.1415926 5358 9793 d0 )

         real*8      p, m, alf, rho, fourpr2

         p = y(1)
         m = y(2)
         alf  = y(3)

         if( r .eq. 0.0d0 ) then
            yprime(1) = 0.0d0
            yprime(2) = 0.0d0
            yprime(3) = 0.0d0
         else
            fourpr2 = 4*pi*r*r
c  BUG: should be using call to CactusEOS           
            rho = p2rho(p)

            yprime(1) = - (p + rho)*(m+fourpr2*r*p)/ r / (r-2*m)

            yprime(2) = fourpr2 * rho

            yprime(3) = alf*(m+fourpr2*r*rho)/ r / (r-2*m)
          endif

         return
      end 

c-----------------------------------------------------------
c     Implements Jacobian  (optional) ...
c   Does absolutely nothing
c-----------------------------------------------------------
      subroutine tov_jac
         implicit    none

         real*8   rho0
         common / com_tov / rho0

         return
      end
#else
      subroutine tov_fcn()
      return 
      end
#endif

```

GRHydro_Bondi_new.F90:
```
 /*@@
   @file      GRHydro_Bondi.F90 
   @date      Wed Jan 13 13:00:49 EST 2010
   @author    Scott C. Noble
   @desc 
   Hydro initial data for the relativistic Bondi solution about 
   a single Schwarzschild black hole. 
   @enddesc 
 @@*/

/*
   Calculates the Bondi solution, or the spherically symmetric hydrostationary 
   solution to a fluid on a static fixed background spacetime. We assume that one can
   calculate a radius "r" from the grid and that with respect to this radial coordinate, 
   the solution satisfies 

   d (\rho u^r) / dr    = 0 

   Assumes that the equation of state is  P = K \rho^\Gamma   and K  is set by 
   the location of the sonic point.     


 -- Implicitly assumes that there is no spin in the geometry as there is no Bondi 
    solution for spinning black holes.  If a spin is specified, a spherically symmetric 
    is still assumed but the 4-velocity is set consistently with the spinning spacetime. 
*/

#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Parameters.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"

# define M_PI     3.14159265358979323846d0  /* pi */

!!$Newton-Raphson parameters:

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)

subroutine GRHydro_Bondi_Iso(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz, imin, jb,N_points
  CCTK_REAL :: ONEmTINY, tiny
  PARAMETER (N_points=100000,ONEmTINY=0.999999d0,tiny=1.0d-12)
  CCTK_REAL :: M, Msq, Mdot, rs, gam, rmin_bondi, rmax_bondi, cs_sq,cs,vs_sq,vs,rhos,gtemp,hs, Kval, Qdot
  CCTK_REAL :: logrmin,dlogr,rhotmp,utmp,vtmp,rspher
  CCTK_REAL :: r_bondi(N_points), logr_bondi(N_points), rho_bondi(N_points), u_bondi(N_points), v_bondi(N_points)
  CCTK_REAL :: drhodr, det, rhocheck, rhocheck2, riso, rnew, rsch, ucheck
  CCTK_REAL :: uiso, uisocheck, vcheck, ucheck2, vcheck2, xhat,yhat, zhat, xp, yp, zp
  CCTK_REAL :: f,df,ddf,a,b,c,rsm,roverm,dudr,uisocheck2,auiso,buiso

  character(400) :: debug_message

  !!$set_bondi_parameters
  M = bondi_central_mass(1)
  Msq  = M*M
  Mdot = mdot_sonicpt_bondi
  rs = r_sonicpt_bondi
  gam = gl_gamma

  write(debug_message,'(a,4f22.14)') "Bondi_pars: ",M,mdot_sonicpt_bondi, &
                                                    r_sonicpt_bondi,gl_gamma
  call CCTK_INFO(debug_message)

  rmin_bondi = M * bondi_rmin(1)
  rmax_bondi = M * bondi_rmax(1)

  cs_sq  =  M / ( 2.*rs - 3.*M ) 

  if( cs_sq > (gam - 1.)) then 
     cs_sq = gam - 1.
     rs = 0.5 * M * ( 3. + 1./cs_sq ) 
  endif
  
  cs     =  sqrt(cs_sq)
  vs_sq  =  M / ( 2. * rs )  
  vs     =  sqrt(vs_sq)
  rhos   =  Mdot / ( 4. * M_PI * vs * rs * rs ) 
  gtemp  =  gam - 1.
  hs     =  1. / ( 1. - cs_sq / (gam - 1.) )
  Kval      = hs * cs_sq * rhos**(-gtemp) / gam 
  Qdot   = hs * hs * ( 1. - 3. * vs_sq ) 
  
  logrmin = log10(rmin_bondi)
  dlogr = (log10(rmax_bondi) - logrmin)/(1.*(N_points-1))

  write(debug_message,'(a,8f22.14)') "More pars: ",cs,vs,rhos,hs,Kval,Qdot,&
                                                   logrmin,dlogr
  call CCTK_INFO(debug_message)

  rhotmp=1.0d30
  imin=1

  do i=1,N_points   
     logr_bondi(i) = logrmin + dlogr*(i-1)
     r_bondi(i) = 10.**(logr_bondi(i))
     utmp = abs(r_bondi(i) - r_sonicpt_bondi) 
     if (utmp < rhotmp) then 
        rhotmp = utmp 
        imin = i 
     endif
  enddo

!!$  rhotmp = -1.  !!$ start with guess
  rhotmp=rhos      !!$ start with value at sonic point!

  do i=imin,N_points
     rspher = r_bondi(i) 
     call find_bondi_solution( rspher, rhotmp, utmp, vtmp, rs, rhos, M, Mdot, Kval, gam, Qdot )
     if(rhotmp < initial_rho_abs_min) then
        rhotmp = initial_rho_abs_min
        utmp = Kval * rhotmp**gl_gamma  / (gl_gamma - 1.)
     endif
     rho_bondi(i) = rhotmp
     u_bondi(i)   = utmp
     v_bondi(i)   = vtmp
  end do
  
!!$  rhotmp = -1.
  rhotmp=rhos      !!$ start with value at sonic point!
  
  do i=imin-1,1,-1
     rspher = r_bondi(i)
     call find_bondi_solution( rspher, rhotmp, utmp, vtmp, rs, rhos, M, Mdot, Kval, gam, Qdot )
     if(rhotmp < initial_rho_abs_min) then
        rhotmp = initial_rho_abs_min
        utmp = K * rhotmp**gl_gamma  / (gl_gamma - 1.)
     endif
     rho_bondi(i) = rhotmp
     u_bondi(i)   = utmp
     v_bondi(i)   = vtmp
  enddo

  if(CCTK_MyProc(cctkGH) .eq. 0) then
     open (47,file="bondi.asc",form="formatted")
     do i=1,N_points   
       write(47,'(i5,4f22.14)')i,r_bondi(i),rho_bondi(i),&
                                u_bondi(i),v_bondi(i)
     end do
     close(47)
  end if

!!$  write(debug_message,'(a,4f22.14)') "i=1:",r_bondi(1),rho_bondi(1),&
!!$                                            u_bondi(1),v_bondi(1)
!!$  call CCTK_INFO(debug_message)
!!$  write(debug_message,'(a,4f22.14)') "i=100:",r_bondi(100),rho_bondi(100),&
!!$                                              u_bondi(100),v_bondi(100)
!!$  call CCTK_INFO(debug_message)
!!$  write(debug_message,'(a,4f22.14)') "i=1000:",r_bondi(1000),rho_bondi(1000),&
!!$                                               u_bondi(1000),v_bondi(1000)
!!$  call CCTK_INFO(debug_message)
!!$  write(debug_message,'(a,4f22.14)') "i=1500:",r_bondi(1500),rho_bondi(1500),&
!!$                                               u_bondi(1500),v_bondi(1500)
!!$  call CCTK_INFO(debug_message)

!!$    // find the derivative near r=M in isotropic coords = r=9/4M in schwarzschild; 
  rnew = 2.25 * M
  j = floor ((log10(rnew) - logrmin) / dlogr + 1.0)
!!$  j = NINT((log10(rnew) - logrmin) / dlogr + 1.0)
  rhocheck = rho_bondi(j)
!!$  call find_bondi_solution_bracket(rnew,rhocheck, ucheck, vcheck, rs, rhos, M, Mdot, Kval, gam, Qdot, &
!!$       rho_bondi(j),rho_bondi(j+1))
  call find_bondi_solution(rnew,rhocheck, ucheck, vcheck, rs, rhos, M, Mdot, Kval, gam, Qdot)
  uisocheck = 4.0*vcheck/3.0
  
!!$ the previous point was r=M in isotropic coords = r=9/4M in schwarzschild;  this one is r=1.01M in isotropic
  rnew = 0.25 * 3.02**2 * M/1.01
  j = floor((log10(rnew) - logrmin) / dlogr + 1.0)
!!$ j = NINT((log10(rnew) - logrmin) / dlogr + 1.0)
  rhocheck2 = rho_bondi(j)
!!$  call find_bondi_solution_bracket( rnew, rhocheck2, ucheck2, vcheck2, rs, rhos, M, Mdot, Kval, gam, Qdot, &
!!$       rho_bondi(j),rho_bondi(j+1))
  call find_bondi_solution( rnew, rhocheck2, ucheck2, vcheck2, rs, rhos, M, Mdot, Kval, gam, Qdot)
  uisocheck2 = vcheck2 / (1.0 - 1.0/2.02) / (1.0+ 1.0/2.02)

  drhodr = 100.0*(rhocheck2-rhocheck)/M 

!!$ Don't divide by M here, to simplify the math
  dudr   = 100.0*(uisocheck2-uisocheck)

  write(debug_message,'(a,3f22.14)') 'Rhocheck:',rhocheck,rhocheck2,drhodr
  call CCTK_INFO(debug_message)
  write(debug_message,'(a,3f22.14)') 'Ucheck:',uisocheck,uisocheck2,dudr
  call CCTK_INFO(debug_message)

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)


  write(debug_message,'(a,3f22.14)') 'Lower bound coordinates:',x(1,1,1),y(1,1,1),z(1,1,1)
  call CCTK_INFO(debug_message)
  write(debug_message,'(a,3f22.14)') 'Upper bound coordinates:',x(nx,ny,nz),y(nx,ny,nz),z(nx,ny,nz)
  call CCTK_INFO(debug_message)
  
  do i=1,nx
     do j=1,ny
        do k=1,nz
           
           xp=x(i,j,k)
           yp=y(i,j,k)
           zp=z(i,j,k)
           
           riso = sqrt(xp*xp + yp*yp + zp*zp +1.0e-16)
           xhat = xp/riso
           yhat = yp/riso
           zhat = zp/riso
           roverm = riso/M
           
           if(roverm > ONEmTINY) then
              rsch = 0.25 * ( 2.*riso + M)**2 / riso
!!$              jb = floor( 0.5 +  (log10(rsch) - logrmin) / dlogr ) 
              jb = floor( (log10(rsch) - logrmin) / dlogr  + 1.0)
!!$              jb = NINT((log10(rsch) - logrmin) / dlogr + 1.0)

              if(jb >= N_points) jb = N_points-1

              rhotmp = rho_bondi(jb)+(rho_bondi(jb+1)-rho_bondi(jb))*&
                  (rsch-r_bondi(jb))/(r_bondi(jb+1)-r_bondi(jb))
!!$              call find_bondi_solution_bracket( rsch,rhotmp, utmp, vtmp, rs, rhos, M, Mdot, Kval, gam, Qdot, &
!!$                   rho_bondi(jb),rho_bondi(jb+1)) 
              call find_bondi_solution( rsch,rhotmp, utmp, vtmp, rs, rhos, M, Mdot, Kval, gam, Qdot)
              rho(i,j,k) = rhotmp
              uiso = vtmp / (1.0 - M/2.0/riso) / (1.0+ M/2.0/riso)
           else
              if(roverm > 0.5d0*ONEmTINY) then
                 rho(i,j,k) = rhocheck+drhodr*riso*(riso-M)/M
              else 
                 rho(i,j,k) = (rhocheck-drhodr*M/4.0)*(1.-cos(2.*M_PI*riso/M))/2.0
              endif
              utmp = Kval * rho(i,j,k)**( gam ) / (gam - 1.)

!!$ match to uiso and dudr at roverm=1
!!$ a R + b R^3 --->   a+b = uisocheck;  a+3b = dudr
!!$ b = (dudr-uisocheck)/2;  a=3*uisocheck-dudr)/2

              auiso = 1.5*uisocheck-0.5*dudr
              buiso = 0.5*dudr-0.5*uisocheck
              uiso =  roverm*(auiso+buiso*roverm**2)
           endif
           eps(i,j,k) = utmp/rhotmp
           
           w_lorentz(i,j,k) = sqrt(1.0+gxx(i,j,k) * uiso**2)
           velx(i,j,k) = -1.0*uiso * xhat / w_lorentz(i,j,k)
           vely(i,j,k) = -1.0*uiso * yhat / w_lorentz(i,j,k)
           velz(i,j,k) = -1.0*uiso * zhat / w_lorentz(i,j,k)
           
           det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))

           call Prim2ConGen(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k), &
                gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), &
                det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k), &
                tau(i,j,k),rho(i,j,k), &
                velx(i,j,k),vely(i,j,k),velz(i,j,k), &
                eps(i,j,k),press(i,j,k),w_lorentz(i,j,k))
           
!           if(riso.gt.1.014d0.and.riso.lt.1.015) then 
           if(z(i,j,k).ge.-1.0d0.and.z(i,j,k).le.1.0d0.and. &
              x(i,j,k).ge.6.5d0.and.x(i,j,k).le.7.5d0.and. &
              y(i,j,k).ge.1.0d0.and.y(i,j,k).le.1.5d0 ) then 
             write(debug_message,'(a,15f22.14)') 'Point to check:', &
               x(i,j,k),y(i,j,k),z(i,j,k),riso,gxx(i,j,k),dens(i,j,k),&
               tau(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),rho(i,j,k),eps(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k)
             call CCTK_INFO(debug_message)
           end if 

        end do
     end do
  end do

  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0

  return

end subroutine GRHydro_Bondi_Iso

subroutine find_bondi_solution(r, rho, u, v, rs, rhos, M, Mdot, Kval, gam, Qdot )
  implicit none
  
  CCTK_REAL :: r, rho, u, v, rs, rhos, M, Mdot, Kval, gam, Qdot
  CCTK_REAL :: ur,r_sol, rho_old
  CCTK_REAL :: f, df, dx, x_old, resid, jac
  CCTK_REAL :: errx, x_orig, x
  CCTK_INT :: n_iter, i_extra, doing_extra, keep_iterating, i_increase
  CCTK_REAL :: vp, h, hp, term

  CCTK_REAL :: newt_tol_b,small_bondi
  CCTK_INT :: max_newt_iter_b, extra_newt_iter_b

  max_newt_iter_b = 30
  newt_tol_b = 1.0e-15
  extra_newt_iter_b = 2
  small_bondi = 1.0e-20

!!$  if(r>8.1043 .and. r<8.1044)write(*,*)'init guess:',r,rho
!!$  write(*,*)'init guess:',r,rho

  if (rho < 0.) then  
     if( r > 0.9*rs .and. r < 1.1*rs ) then 
        rho = rhos
     else
        if(r < rs) then
           ur = r**(-0.5)
        else     
           ur = 0.5*r**(-1.5)
        endif
        rho = Mdot / (4.*M_PI * r * r * ur)
     endif
  endif
  
!!$  if(r>8.1043 .and. r<8.1044)
!!$  write(*,*)'init guess:',r,ur,rho,rs,rhos,Mdot
!!$  if(r<1.0001e-10)write(*,*)'init guess:',r,ur,rho,rs,rhos,Mdot
!!$  write(*,*)'init guess:',r,ur,rho,rs,rhos,Mdot

  !!$ set global variables needed by residual function:
  r_sol = r 


!!$ Use Newton's method to find rho:
!!$  gnr_bondi( rho, NEWT_DIM_B, bondi_resid)     
  errx = 1.0
  df=1.0
  f=1.0
  doing_extra = 0

  rho_old=rho
  x=rho

  n_iter = 0

!!$ Start the Newton-Raphson iterations : 
  keep_iterating = 1
  do while( keep_iterating == 1 ) 
     
     hp  =  Kval * gam *  x**(gam - 2.)   !!$   //   dh/drho 
     h   =  1. +  hp * x / ( gam - 1. )
     v   =  Mdot / ( 4. * M_PI * r_sol * r_sol * x )    
     vp  =  -v / x   !!$ //  dv/drho
     term = 1. - 2.*M/r_sol + v*v
     resid  =  -Qdot  +  h * h * term
     jac =  2. * h *( hp*term + h*v*vp )
     dx = -resid / jac
     f = 0.5*resid**2
     df = -2. * f
     
     /* Save old values before calculating the new: */
     errx = 0.
     x_old = x
     
     x=x+dx

!!$     if(r>8.1043 .and. r<8.1044)write(*,*)'iter:',x,dx,resid,jac
     
!!$    /****************************************/
!!$    /* Calculate the convergence criterion */
!!$    /****************************************/
     
!!$    /* For the new criterion, always look at relative error in indep. variable: */
!!$    // METHOD specific:
     if(x==0) then
        errx = abs(dx)
        x = small_bondi
     else
        errx = abs(dx/x)
     endif
     
!!$    /*****************************************************************************/
!!$    /* If we've reached the tolerance level, then just do a few extra iterations */
!!$    /*  before stopping                                                          */
!!$    /*****************************************************************************/

!!$     if(r>8.1043 .and. r<8.1044)write(*,*)'iter3:',errx,newt_tol_b,keep_iterating, &
!!$          doing_extra,i_extra

     if((abs(errx)<=newt_tol_b) .and. (doing_extra == 0) .and. (extra_newt_iter_b > 0)) &
          doing_extra=1

    if( doing_extra == 1 ) i_extra=i_extra+1 
    
    if( ((abs(errx) <= newt_tol_b).and.(doing_extra == 0)) .or. &
         (i_extra > extra_newt_iter_b) .or. (n_iter >= (max_newt_iter_b-1)) ) &
         keep_iterating = 0

!!$     if(r>8.1043 .and. r<8.1044)write(*,*)'iter4:',errx,newt_tol_b,keep_iterating, &
!!$          doing_extra,i_extra

    
    n_iter=n_iter+1
    
 end do

 rho=x
 
!!$ Calculate other quantities:
 u = Kval * rho**( gam ) / (gam - 1.)
 v = Mdot / ( 4. * M_PI * r * r * rho )

!!$ if(r>8.1043 .and. r<8.1044)
!!$ write(*,*)'final:',r,rho,u,v

 
 return
 
end subroutine find_bondi_solution

    subroutine find_bondi_solution_bracket(r, rho, u, v, rs, rhos, M, Mdot, Kval, gam, Qdot,rho1,rho2 )
      implicit none
    
      CCTK_REAL rho1,rho2
      CCTK_REAL :: r, rho, u, v, rs, rhos, M, Mdot, Kval, gam, Qdot
      CCTK_REAL :: ur,r_sol, rho_old
      CCTK_REAL :: f, df, dx, x_old, resid, jac
      CCTK_REAL :: errx, x_orig, x
      CCTK_INT :: n_iter, i_extra, doing_extra, keep_iterating, i_increase
      CCTK_REAL :: vp, h, hp, term
      
      CCTK_REAL :: newt_tol_b,small_bondi
      CCTK_INT :: max_newt_iter_b, extra_newt_iter_b

      if(rho.gt.rho1.or.rho.lt.rho2) then
         write(6,*)'find_bondi_solution_bracket: Very bad rho! (rholow,rhoup,rho) = ',rho1,rho2,rho
         stop
      endif

         write(6,*)'find_bondi_solution_bracket: (rholow,rhoup,rho) = ',rho1,rho2,rho
    
      max_newt_iter_b = 30
      newt_tol_b = 1.0e-15
      extra_newt_iter_b = 2
      small_bondi = 1.0e-20
      
!!$  if(r>8.1043 .and. r<8.1044)write(*,*)'init guess:',r,rho
!!$  write(*,*)'init guess:',r,rho
      
!!$      if (rho < 0.) then  
!!$         if( r > 0.9*rs .and. r < 1.1*rs ) then 
!!$            rho = rhos
!!$         else
!!$            if(r < rs) then
!!$               ur = r**(-0.5)
!!$            else     
!!$               ur = 0.5*r**(-1.5)
!!$            endif
!!$            rho = Mdot / (4.*M_PI * r * r * ur)
!!$         endif
!!$      endif
      
!!$  if(r>8.1043 .and. r<8.1044)
!!$  write(*,*)'init guess:',r,ur,rho,rs,rhos,Mdot
!!$  if(r<1.0001e-10)write(*,*)'init guess:',r,ur,rho,rs,rhos,Mdot
!!$  write(*,*)'init guess:',r,ur,rho,rs,rhos,Mdot
      
!!$ set global variables needed by residual function:

      r_sol = r 
      
      
!!$ Use Newton's method to find rho:
!!$  gnr_bondi( rho, NEWT_DIM_B, bondi_resid)     
      errx = 1.0
      df=1.0
      f=1.0
      doing_extra = 0
      
      rho_old=rho
      x=rho
      
      n_iter = 0
      
!!$ Start the Newton-Raphson iterations : 
      keep_iterating = 1
      do while( keep_iterating == 1 ) 
         
         hp  =  Kval * gam *  x**(gam - 2.)   !!$   //   dh/drho 
         h   =  1. +  hp * x / ( gam - 1. )
         v   =  Mdot / ( 4. * M_PI * r_sol * r_sol * x )    
         vp  =  -v / x   !!$ //  dv/drho
         term = 1. - 2.*M/r_sol + v*v
         resid  =  -Qdot  +  h * h * term
         jac =  2. * h *( hp*term + h*v*vp )
         dx = -resid / jac
         f = 0.5*resid**2
         df = -2. * f
         
         errx = 0.
         x_old = x
         
         x=x+dx

         if(x.gt.rho1.or.x.lt.rho2) then
!!$            write(6,*)'Bad rho! ',rho1,rho2,rho
            if(x.gt.rho1)x=0.5*(x_old+rho1)
            if(x.lt.rho2)x=0.5*(x_old+rho2)
         endif

         if(x.gt.rho1.or.x.lt.rho2) then
            write(6,*)'find_bondi_solution_bracket: Bad rho, bad! (rholow,rhoup,rho) = ',rho1,rho2,rho
            stop
         endif
         
!!$     if(r>8.1043 .and. r<8.1044)write(*,*)'iter:',x,dx,resid,jac
         
!!$    /****************************************/
!!$    /* Calculate the convergence criterion */
!!$    /****************************************/
         
!!$    /* For the new criterion, always look at relative error in indep. variable: */
!!$    // METHOD specific:
         if(x==0) then
            errx = abs(dx)
            x = small_bondi
         else
            errx = abs(dx/x)
         endif
         
!!$    /*****************************************************************************/
!!$    /* If we've reached the tolerance level, then just do a few extra iterations */
!!$    /*  before stopping                                                          */
!!$    /*****************************************************************************/
         
!!$     if(r>8.1043 .and. r<8.1044)write(*,*)'iter3:',errx,newt_tol_b,keep_iterating, &
!!$          doing_extra,i_extra
         
         if((abs(errx)<=newt_tol_b) .and. (doing_extra == 0) .and. (extra_newt_iter_b > 0)) &
              doing_extra=1
         
         if( doing_extra == 1 ) i_extra=i_extra+1 
         
         if( ((abs(errx) <= newt_tol_b).and.(doing_extra == 0)) .or. &
              (i_extra > extra_newt_iter_b) .or. (n_iter >= (max_newt_iter_b-1)) ) then
            keep_iterating = 0
            if(n_iter>=(max_newt_iter_b-1))write(6,*)'find_bondi_solution_bracket: Extra iterations!'
         endif
         
!!$     if(r>8.1043 .and. r<8.1044)write(*,*)'iter4:',errx,newt_tol_b,keep_iterating, &
!!$          doing_extra,i_extra
         
         
         n_iter=n_iter+1
         
      end do
      
      rho=x
      
!!$ Calculate other quantities:
      u = Kval * rho**( gam ) / (gam - 1.)
      v = Mdot / ( 4. * M_PI * r * r * rho )
      
!!$ if(r>8.1043 .and. r<8.1044)
!!$ write(*,*)'final:',r,rho,u,v
      
      
      return
      
    end subroutine find_bondi_solution_bracket


```

GRHydro_ReadConformalData.F90:
```
 /*@@
   @file      GRHydro_ReadConformalData.F90
   @date      Fri Jul  6 12:29:27 2007
   @author    Luca Baiotti
   @desc 
   Set the missing quantities, after reading in from file initial data from conformally-flat codes (Garching)
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "SpaceMask.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)

 /*@@
   @routine    GRHydro_ReadConformalData
   @date       Fri Jul  6 12:31:18 2007
   @author     Luca Baiotti
   @desc 
   Set the missing quantities, after reading in from file initial data from conformally-flat codes (Garching)
   @enddesc 
   @calls     
   @calledby   
   @history 

   @endhistory 

@@*/

subroutine GRHydro_ReadConformalData(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS

  CCTK_INT :: i,j,k,handle,ierr
  CCTK_REAL :: rho_min, det

! begin EOS Omni vars
  CCTK_INT  :: n = 1
  CCTK_INT  :: poly_eoskey = 0
  CCTK_INT  :: keytemp = 0
  CCTK_INT  :: anyerr = 0
  CCTK_INT  :: keyerr(1) = 0
  CCTK_REAL :: rf_precision = 1.0d-10
  CCTK_REAL :: xpress(1) = 0.0d0
  CCTK_REAL :: xeps(1) = 0.0d0
  CCTK_REAL :: xtemp(1) = 0.0d0
  CCTK_REAL :: xye(1) = 0.0d0
  poly_eoskey = EOS_Omni_GetHandle("2D_Polytrope")
! end EOS Omni vars

  ! only gxx has been read in; copy it into gyy and gzz as well
  gyy = gxx
  gzz = gxx

  ! set the other components to zero
  gxy = 0.0
  gxz = 0.0
  gyz = 0.0

  ! set the extrinsic curvature to zero
  kxx = 0.0
  kxy = 0.0
  kxz = 0.0

  kyy = 0.0
  kyz = 0.0
  kzz = 0.0  

  ! set the shift to zero (the lapse is read in)
  betax = 0.0
  betay = 0.0
  betaz = 0.0


  ! atmosphere

  if (rho_abs_min > 0.0) then
    rho_min = rho_abs_min
  else
    call CCTK_WARN(0,"For now, with ReadConformalData you need to set rho_abs_min")
  end if

  if (initial_rho_abs_min > 0.0) then
    rho_min = initial_rho_abs_min;
  else if (initial_rho_rel_min > 0.0) then
    call CCTK_WARN(1,"Setting initial_rho_rel_min is ignored with ReadConformalData, for the time being")
  end if

  if (initial_atmosphere_factor > 0.0) rho_min = rho_min * initial_atmosphere_factor

  ierr = 0
  do i=1,cctk_lsh(1)
    do j=1,cctk_lsh(2)
      do k=1,cctk_lsh(3)

 !       write(*,*) i,j,k, rho(i,j,k)
        ! check on the read-in rho
        if (rho(i,j,k) > 0.0) then
          write(*,*) i,j,k, rho(i,j,k)
          ierr = ierr+1
        end if
        
        ! set the atmosphere
        if (rho(i,j,k) <= 0.d0) rho(i,j,k) = rho_min

!        if (rho(i,j,k) > 1.d-9)  write(*,*) i,j,k,rho(i,j,k)
      end do
    end do
  end do

!  if (ierr == 0) call CCTK_WARN(0,"rho.h5 contains only zeroes: stopping the simulation")

!  write(*,*)"rho min",  rho_min

  
!!$  where(rho < rho_min)
!!$    rho = rho_min
!!$  end where


  ! set pressure and eps from rho, using the polytropic EoS

!  handle = EOS_Handle("2D_Polytrope")

!  if (handle < 0) call CCTK_WARN(0,"For this hack you need to compile with EOS_Polytrope")

!  eos_k = EOS_Pressure(GRHydro_eos_handle, 1.0, 1.0)
!  eos_gamma = 1.0 + eos_k / EOS_SpecificIntEnergy(GRHydro_eos_handle,1.0,1.0)


!  press = eos_k * rho**eos_gamma
  
  do i=1,cctk_lsh(1)
    do j=1,cctk_lsh(2)
      do k=1,cctk_lsh(3)

        call EOS_Omni_EpsFromPress(poly_eoskey,keytemp,rf_precision,&
             n,rho(i,j,k),xeps,xtemp,xye,&
             press(i,j,k),eps(i,j,k),keyerr,anyerr)

      end do
    end do
  end do


  ! set velocities to zero

  velx(:,:,:) = 0.0
  vely(:,:,:) = 0.0
  velz(:,:,:) = 0.0
  w_lorentz = 1.0


  ! Compute conserved variables

  do i=1,cctk_lsh(1)
    do j=1,cctk_lsh(2)
      do k=1,cctk_lsh(3)
        
        call SpatialDet(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),&
             gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),det)
        
        if (CCTK_EQUALS(GRHydro_eos_type,"Polytype")) then
          call Prim2ConPoly(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
               gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
               det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
               tau(i,j,k),rho(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k),&
               eps(i,j,k),press(i,j,k),w_lorentz(i,j,k))
        else
          call Prim2ConGen(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
               gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
               det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
               tau(i,j,k),rho(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k),&
             eps(i,j,k),press(i,j,k),w_lorentz(i,j,k))
        end if
              
      end do
    end do
  end do
  

  return
  
end subroutine GRHydro_ReadConformalData

```

GRHydro_BondiM_new.F90:
```
 /*@@
   @file      GRHydro_Bondi.F90 
   @date      Wed Jan 13 13:00:49 EST 2010
   @author    Scott C. Noble
   @desc 
   Hydro initial data for the relativistic Bondi solution about 
   a single Schwarzschild black hole. 
   @enddesc 
 @@*/

/*
   Calculates the Bondi solution, or the spherically symmetric hydrostationary 
   solution to a fluid on a static fixed background spacetime. We assume that one can
   calculate a radius "r" from the grid and that with respect to this radial coordinate, 
   the solution satisfies 

   d (\rho u^r) / dr    = 0 

   Assumes that the equation of state is  P = K \rho^\Gamma   and K  is set by 
   the location of the sonic point.     


 -- Implicitly assumes that there is no spin in the geometry as there is no Bondi 
    solution for spinning black holes.  If a spin is specified, a spherically symmetric 
    is still assumed but the 4-velocity is set consistently with the spinning spacetime. 
*/

#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Parameters.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"

# define M_PI     3.14159265358979323846d0  /* pi */

!!$Newton-Raphson parameters:

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)
#define Bvecx(i,j,k) Bvec(i,j,k,1)
#define Bvecy(i,j,k) Bvec(i,j,k,2)
#define Bvecz(i,j,k) Bvec(i,j,k,3)
#define Bconsx(i,j,k) Bcons(i,j,k,1)
#define Bconsy(i,j,k) Bcons(i,j,k,2)
#define Bconsz(i,j,k) Bcons(i,j,k,3)

subroutine GRHydro_BondiM_Iso(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz, imin, jb,N_points
  CCTK_REAL :: ONEmTINY, tiny
  PARAMETER (N_points=100000,ONEmTINY=0.999999d0,tiny=1.0d-12)
  CCTK_REAL :: M, Msq, Mdot, rs, gam, rmin_bondi, rmax_bondi, cs_sq,cs,vs_sq,vs,rhos,gmo,hs, Kval, Qdot
  CCTK_REAL :: psonic, riso_s
  CCTK_REAL :: logrmin,dlogr,rhotmp,utmp,vtmp,rspher
  CCTK_REAL :: r_bondi(N_points), logr_bondi(N_points), rho_bondi(N_points), u_bondi(N_points), v_bondi(N_points)
  CCTK_REAL :: drhodr, det, sdet, rhocheck, rhocheck2, riso, rnew, rsch, ucheck
  CCTK_REAL :: uiso, uisocheck, vcheck, ucheck2, vcheck2, xhat,yhat, zhat, xp, yp, zp
  CCTK_REAL :: f,df,ddf,a,b,c,rsm,roverm,dudr,uisocheck2,auiso,buiso
  CCTK_REAL :: bondi_bsmooth, bmag, bsonic, psonicmag

  character(400) :: debug_message

  !!$set_bondi_parameters
  M = bondi_central_mass(1)
  Msq  = M*M
  Mdot = mdot_sonicpt_bondi
  rs = r_sonicpt_bondi
  riso_s = 0.5d0*(rs-M+sqrt(rs*(rs-2.0d0*M)))
  gam = gl_gamma

  write(debug_message,'(a,2f22.14)') "Bondi_pars: M, mdot_sonicpt_bondi,",&
                                                  M,mdot_sonicpt_bondi
  call CCTK_INFO(debug_message)
  write(debug_message,'(a,2f22.14)') "Bondi_pars: r_sonicpt_bondi,gl_gamma", &
                                                    r_sonicpt_bondi,gl_gamma 
  call CCTK_INFO(debug_message)
  write(debug_message,'(a,f22.14)') "Bondi_pars: riso_s", riso_s
  call CCTK_INFO(debug_message)

  rmin_bondi = M * bondi_rmin(1)
  rmax_bondi = M * bondi_rmax(1)

  cs_sq  =  M / ( 2.*rs - 3.*M ) 

  if( cs_sq > (gam - 1.)) then 
     cs_sq = gam - 1.
     rs = 0.5 * M * ( 3. + 1./cs_sq ) 
  endif
  
  cs     =  sqrt(cs_sq)
  vs_sq  =  M / ( 2. * rs )  
  vs     =  sqrt(vs_sq)
  rhos   =  Mdot / ( 4. * M_PI * vs * rs * rs ) 
  gmo  =  gam - 1.
  hs     =  1. / ( 1. - cs_sq / (gam - 1.) )
  Kval      = hs * cs_sq * rhos**(-gmo) / gam 
  Qdot   = hs * hs * ( 1. - 3. * vs_sq ) 
  ! Get the pressure value psonic at the sonic point
  psonic = Kval * rhos**gam
  
  logrmin = log10(rmin_bondi)
  dlogr = (log10(rmax_bondi) - logrmin)/(1.*(N_points-1))

  write(debug_message,'(a,4f22.14)') "Bondi pars: cs,vs,rhos,hs",cs,vs,rhos,hs
  call CCTK_INFO(debug_message)
  write(debug_message,'(a,2f22.14)') "Bondi pars: Kval,Qdot ",Kval,Qdot
  call CCTK_INFO(debug_message)
  write(debug_message,'(a,2f22.14)') "Bondi pars: logrmin,dlogr",logrmin,dlogr
  call CCTK_INFO(debug_message)

  rhotmp=1.0d30
  imin=1

  do i=1,N_points   
     logr_bondi(i) = logrmin + dlogr*(i-1)
     r_bondi(i) = 10.**(logr_bondi(i))
     utmp = abs(r_bondi(i) - r_sonicpt_bondi) 
     if (utmp < rhotmp) then 
        rhotmp = utmp 
        imin = i 
     endif
  enddo

!!$  rhotmp = -1.  !!$ start with guess
  rhotmp=rhos      !!$ start with value at sonic point!


  do i=imin,N_points
     rspher = r_bondi(i) 
     call find_bondi_solution( rspher, rhotmp, utmp, vtmp, rs, rhos, M, Mdot, Kval, gam, Qdot )
     if(rhotmp < initial_rho_abs_min) then
        rhotmp = initial_rho_abs_min
        utmp = Kval * rhotmp**gl_gamma  / (gl_gamma - 1.)
     endif
     rho_bondi(i) = rhotmp
     u_bondi(i)   = utmp
     v_bondi(i)   = vtmp
  end do
  
!!$  rhotmp = -1.
  rhotmp=rhos      !!$ start with value at sonic point!
  
  do i=imin-1,1,-1
     rspher = r_bondi(i)
     call find_bondi_solution( rspher, rhotmp, utmp, vtmp, rs, rhos, M, Mdot, Kval, gam, Qdot )
     if(rhotmp < initial_rho_abs_min) then
        rhotmp = initial_rho_abs_min
        utmp = K * rhotmp**gl_gamma  / (gl_gamma - 1.)
     endif
     rho_bondi(i) = rhotmp
     u_bondi(i)   = utmp
     v_bondi(i)   = vtmp
  enddo

  if (CCTK_MyProc(cctkGH) == 0) then 
    open (47,file="bondi.asc",form="formatted")
    do i=1,N_points   
      write(47,'(i5,4f22.14)')i,r_bondi(i),rho_bondi(i),&
                               u_bondi(i),v_bondi(i)
    end do
    close(47)
  end if

!!$  write(debug_message,'(a,4f22.14)') "i=1:",r_bondi(1),rho_bondi(1),&
!!$                                            u_bondi(1),v_bondi(1)
!!$  call CCTK_INFO(debug_message)
!!$  write(debug_message,'(a,4f22.14)') "i=100:",r_bondi(100),rho_bondi(100),&
!!$                                              u_bondi(100),v_bondi(100)
!!$  call CCTK_INFO(debug_message)
!!$  write(debug_message,'(a,4f22.14)') "i=1000:",r_bondi(1000),rho_bondi(1000),&
!!$                                               u_bondi(1000),v_bondi(1000)
!!$  call CCTK_INFO(debug_message)
!!$  write(debug_message,'(a,4f22.14)') "i=1500:",r_bondi(1500),rho_bondi(1500),&
!!$                                               u_bondi(1500),v_bondi(1500)
!!$  call CCTK_INFO(debug_message)

!!$    // find the derivative near r=M in isotropic coords = r=9/4M in schwarzschild; 
  rnew = 2.25 * M
  j = floor ((log10(rnew) - logrmin) / dlogr + 1.0)
!!$  j = NINT((log10(rnew) - logrmin) / dlogr + 1.0)
  rhocheck = rho_bondi(j)
  call find_bondi_solution(rnew,rhocheck, ucheck, vcheck, rs, rhos, M, Mdot, Kval, gam, Qdot )
  uisocheck = 4.0*vcheck/3.0
  
!!$ the previous point was r=M in isotropic coords = r=9/4M in schwarzschild;  this one is r=1.01M in isotropic
  rnew = 0.25 * 3.02**2 * M/1.01
  j = floor((log10(rnew) - logrmin) / dlogr + 1.0)
!!$ j = NINT((log10(rnew) - logrmin) / dlogr + 1.0)
  rhocheck2 = rho_bondi(j)
  call find_bondi_solution( rnew, rhocheck2, ucheck2, vcheck2, rs, rhos, M, Mdot, Kval, gam, Qdot )
  uisocheck2 = vcheck2 / (1.0 - 1.0/2.02) / (1.0+ 1.0/2.02)

  drhodr = 100.0*(rhocheck2-rhocheck)/M 

!!$ Don't divide by M here, to simplify the math
  dudr   = 100.0*(uisocheck2-uisocheck)

  write(debug_message,'(a,3f22.14)') 'Rhocheck:',rhocheck,rhocheck2,drhodr
  call CCTK_INFO(debug_message)
  write(debug_message,'(a,3f22.14)') 'Ucheck:',uisocheck,uisocheck2,dudr
  call CCTK_INFO(debug_message)

  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)



 ! Note that: B^r(t,r) = bondi_bmag M^2 / ( sqrt(\Lambda) \lambda r^2 )
 ! according to eq. 82 of PRD82 084031 (2010). Assuming Schwarzschild 
 ! coordinates B^r = bondi_bmag M^2/r^2 sqrt(1-2M/r). We can show that
 ! b^\mu b_\mu = (B^r)^2 and from the definition of plasma beta parameter
 ! we can find that bondi_bmag = sqrt(2P/\beta) r^2/M 1/sqrt(1-2M/r) 
 if(set_bondi_beta_sonicpt.ne.0) then
  bmag = sqrt(2.0d0*psonic/bondi_beta_sonicpt)*rs**2/M &
              /sqrt(1.0d0-2.0d0*M/rs)
 else
  bmag = bondi_bmag
 end if 
 bsonic = bmag*(M/rs)**2 * sqrt(1.0d0-2.0d0*M/rs)
 psonicmag = 0.5d0*bsonic**2

 write(debug_message,'(a,2f22.14)')'Bondi pars: bondi_bmag,bondi_beta_sonicpt',&
                                                bmag,bondi_beta_sonicpt
 call CCTK_INFO(debug_message)
 write(debug_message,'(a,2f22.14)')'Bondi pars: rs,bsonic',rs,bsonic
 call CCTK_INFO(debug_message)
 write(debug_message,'(a,2f22.14)')'Bondi pars: psonic,psonicmag',&
                                                psonic,psonicmag
 call CCTK_INFO(debug_message)

  do i=1,nx
     do j=1,ny
        do k=1,nz
           
           xp=x(i,j,k)
           yp=y(i,j,k)
           zp=z(i,j,k)
           
           riso = sqrt(xp*xp + yp*yp + zp*zp +1.0e-16)
           xhat = xp/riso
           yhat = yp/riso
           zhat = zp/riso
           roverm = riso/M

           bondi_bsmooth = 1.0d0
           
           if(roverm > ONEmTINY) then
              rsch = 0.25 * ( 2.*riso + M)**2 / riso
!!$              jb = floor( 0.5 +  (log10(rsch) - logrmin) / dlogr ) 
              jb = floor( (log10(rsch) - logrmin) / dlogr  + 1.0)
!!$              jb = NINT((log10(rsch) - logrmin) / dlogr + 1.0)

              if(jb >= N_points) jb = N_points-1

              rhotmp = rho_bondi(jb)+(rho_bondi(jb+1)-rho_bondi(jb))*&
                  (rsch-r_bondi(jb))/(r_bondi(jb+1)-r_bondi(jb))
!!$              call find_bondi_solution_bracket( rsch,rhotmp, utmp, vtmp, rs, rhos, M, Mdot, Kval, gam, Qdot, &
!!$                   rho_bondi(jb),rho_bondi(jb+1)) 
              call find_bondi_solution( rsch,rhotmp, utmp, vtmp, rs, rhos, M, Mdot, Kval, gam, Qdot)
              rho(i,j,k) = rhotmp
              uiso = vtmp / (1.0 - M/2.0/riso) / (1.0+ M/2.0/riso)
           else
              if(roverm > 0.5d0*ONEmTINY) then
                 rho(i,j,k) = rhocheck+drhodr*riso*(riso-M)/M
              else 
                 rho(i,j,k) = (rhocheck-drhodr*M/4.0)*(1.-cos(2.*M_PI*riso/M))/2.0
                 bondi_bsmooth = 8.0d0*riso**3 
              endif
              utmp = Kval * rho(i,j,k)**( gam ) / (gam - 1.)

!!$ match to uiso and dudr at roverm=1
!!$ a R + b R^3 --->   a+b = uisocheck;  a+3b = dudr
!!$ b = (dudr-uisocheck)/2;  a=3*uisocheck-dudr)/2

              auiso = 1.5*uisocheck-0.5*dudr
              buiso = 0.5*dudr-0.5*uisocheck
              uiso =  roverm*(auiso+buiso*roverm**2)
           endif
           eps(i,j,k) = utmp/rhotmp
           
           w_lorentz(i,j,k) = sqrt(1.0+gxx(i,j,k) * uiso**2)
           velx(i,j,k) = -1.0*uiso * xhat / w_lorentz(i,j,k)
           vely(i,j,k) = -1.0*uiso * yhat / w_lorentz(i,j,k)
           velz(i,j,k) = -1.0*uiso * zhat / w_lorentz(i,j,k)
           
           det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))
           sdet = sqrt(det)

           Bvecx(i,j,k) = bondi_bsmooth*bmag*M**2*xhat/sdet/riso**2
           Bvecy(i,j,k) = bondi_bsmooth*bmag*M**2*yhat/sdet/riso**2
           Bvecz(i,j,k) = bondi_bsmooth*bmag*M**2*zhat/sdet/riso**2


           call Prim2ConGenM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k), &
                          gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), &
                          det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k), &
                    tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k), &
                          rho(i,j,k),velx(i,j,k),vely(i,j,k),velz(i,j,k), &
                          eps(i,j,k),press(i,j,k), &
                  Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),w_lorentz(i,j,k))

           if(evolve_entropy.ne.0) then
             entropy(i,j,k) = press(i,j,k) * rho(i,j,k)**(-gmo)
             entropycons(i,j,k) = sdet * entropy(i,j,k) * w_lorentz(i,j,k)
           end if

!!$        write(48,'(3f22.14)')riso,uiso,bondi_bsmooth*bondi_bmag
           
        end do
     end do
  end do

  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0
  Bconsrhs = 0.d0
  if(evolve_entropy.ne.0) then
    entropyrhs = 0.d0
  end if

  return

end subroutine GRHydro_BondiM_Iso



```

GRHydro_ShockTube.F90:
```
 /*@@
   @file      GRHydro_ShockTube.F90
   @date      Sat Jan 26 02:53:25 2002
   @author    Ian Hawke
   @desc 
   Initial data of the shock tube type.
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)

 /*@@
   @routine    GRHydro_shocktube
   @date       Sat Jan 26 02:53:49 2002
   @author     Ian Hawke
   @desc 
   Initial data for shock tubes. Either diagonal or parallel to
   a coordinate axis. Either Sods problem or the standard shock tube.
   @enddesc 
   @calls     
   @calledby   
   @history 
   Expansion and alteration of the test code from GRAstro_Hydro, 
   written by Mark Miller.
   @endhistory 

@@*/

subroutine GRHydro_shocktube(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz
  CCTK_REAL :: direction, det
  CCTK_REAL :: rhol, rhor, velxl, velxr, velyl, velyr, &
       velzl, velzr, epsl, epsr
  
  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)
  
  do i=1,nx
    do j=1,ny
      do k=1,nz
        if (CCTK_EQUALS(shocktube_type,"diagshock")) then
          direction = x(i,j,k) - shock_xpos + &
               y(i,j,k) - shock_ypos + z(i,j,k) - shock_zpos
        else if (CCTK_EQUALS(shocktube_type,"xshock")) then
          direction = x(i,j,k) - shock_xpos
        else if (CCTK_EQUALS(shocktube_type,"yshock")) then
          direction = y(i,j,k) - shock_ypos
        else if (CCTK_EQUALS(shocktube_type,"zshock")) then
          direction = z(i,j,k) - shock_zpos
        else if (CCTK_EQUALS(shocktube_type,"sphere")) then
          direction = sqrt((x(i,j,k)-shock_xpos)**2+&
                           (y(i,j,k)-shock_ypos)**2+&
                           (z(i,j,k)-shock_zpos)**2)-shock_radius
        end if
        if (CCTK_EQUALS(shock_case,"Simple")) then
          rhol = 10.d0
          rhor = 1.d0
          velxl = 0.d0
          velxr = 0.d0
          velyl = 0.d0
          velyr = 0.d0
          velzl = 0.d0
          velzr = 0.d0
          epsl = 2.d0
          epsr = 1.d-6
        else if (CCTK_EQUALS(shock_case,"Sod")) then
          rhol = 1.d0
          rhor = 0.125d0
          velxl = 0.d0
          velxr = 0.d0
          velyl = 0.d0
          velyr = 0.d0
          velzl = 0.d0
          velzr = 0.d0
          epsl = 1.5d0
          epsr = 1.2d0
        else if (CCTK_EQUALS(shock_case,"Balsaralike1")) then
          rhol = 1.0d0
          rhor = 0.125d0
          velxl = 0.0d0
          velxr = 0.0d0
          velyl = 0.0d0
          velyr = 0.0d0
          velzl = 0.0d0
          velzr = 0.0d0
          epsl = 1.0d0/rhol
          epsr = 0.1d0/rhor
!!$This line only for polytrope, k=1
!!$          epsr = 0.375d0
        else if (CCTK_EQUALS(shock_case,"Blast")) then
          rhol = 1.d0
          rhor = 1.d0
          velxl = 0.d0
          velxr = 0.d0
          velyl = 0.d0
          velyr = 0.d0
          velzl = 0.d0
          velzr = 0.d0
          epsl = 1500.d0
          epsr = 1.5d-2
        else
          call CCTK_WARN(0,"Shock case not recognized")
        end if

        if ( ((change_shock_direction==0).and.(direction .lt. 0.0d0)).or.& 
             ((change_shock_direction==1).and.(direction .gt. 0.0d0)) ) then
          rho(i,j,k) = rhol
          velx(i,j,k) = velxl
          vely(i,j,k) = velyl
          velz(i,j,k) = velzl
          eps(i,j,k) = epsl
        else
          rho(i,j,k) = rhor
          velx(i,j,k) = velxr
          vely(i,j,k) = velyr
          velz(i,j,k) = velzr
          eps(i,j,k) = epsr
        end if

        det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))

        if (CCTK_EQUALS(GRHydro_eos_type,"Polytype")) then
          call Prim2ConPoly(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
               gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
               det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
               tau(i,j,k),rho(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k),&
               eps(i,j,k),press(i,j,k),w_lorentz(i,j,k))
        else
          call Prim2ConGen(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
               gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
               det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
               tau(i,j,k),rho(i,j,k),&
               velx(i,j,k),vely(i,j,k),velz(i,j,k),&
               eps(i,j,k),press(i,j,k),w_lorentz(i,j,k))
        end if
    enddo
    enddo
  enddo

  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0

  return
  
end subroutine GRHydro_shocktube

subroutine GRHydro_shocktube_hot(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz
  CCTK_REAL :: direction, det
  CCTK_REAL :: rhol, rhor, velxl, velxr, velyl, velyr, &
       velzl, velzr, epsl, epsr, templ, tempr, yel, yer
  CCTK_REAL :: vlowx, vlowy, vlowz, w, tenthalpy

! begin EOS Omni vars                                                                                                  
  CCTK_INT :: n,keytemp,anyerr,keyerr(1)
  CCTK_INT :: handle
  character(len=256) :: warnline
  ! handle for nuclear EOS
  handle=4
  n = 1;keytemp = 0;anyerr = 0;keyerr(1) = 0
! end EOS Omni vars      
  
  nx = cctk_ash(1)
  ny = cctk_ash(2)
  nz = cctk_ash(3)
  
  call CCTK_INFO("Setting up initial data for hot shocktube")

  if(.not.CCTK_EQUALS(Y_e_evolution_method,"GRHydro").or.&
       .not.CCTK_EQUALS(temperature_evolution_method,"GRHydro")) then
     call CCTK_WARN(0,"Must have Y_e_evolution_method and temperature_evolution_method set to GRHydro")
  endif

  if (nuceos_read_table.eq.0) then
     call CCTK_WARN(0,"You must read in a nuclear EOS table for initial data shocktube_hot to work!")
  endif

  if (.not.CCTK_EQUALS(GRHydro_eos_table,"nuc_eos").or..not.CCTK_EQUALS(GRHydro_eos_type,"General")) then
     call CCTK_WARN(0,"You must set GRHydro::GRHydro_eos_table = nuc_eos and GRHydro::GRHydro_eos_type = General!")
  endif

  do i=1,nx
    do j=1,ny
      do k=1,nz
        if (CCTK_EQUALS(shocktube_type,"diagshock")) then
          direction = x(i,j,k) - shock_xpos + &
               y(i,j,k) - shock_ypos + z(i,j,k) - shock_zpos
        else if (CCTK_EQUALS(shocktube_type,"xshock")) then
          direction = x(i,j,k) - shock_xpos
        else if (CCTK_EQUALS(shocktube_type,"yshock")) then
          direction = y(i,j,k) - shock_ypos
        else if (CCTK_EQUALS(shocktube_type,"zshock")) then
          direction = z(i,j,k) - shock_zpos
        else if (CCTK_EQUALS(shocktube_type,"sphere")) then
          direction = sqrt((x(i,j,k)-shock_xpos)**2+&
                           (y(i,j,k)-shock_ypos)**2+&
                           (z(i,j,k)-shock_zpos)**2)-shock_radius
        end if
        if (CCTK_EQUALS(shock_case,"Simple")) then
          rhol = 1.62e-8
          rhor = 1.62e-9
          velxl = 0.d0
          velxr = 0.d0
          velyl = 0.d0
          velyr = 0.d0
          velzl = 0.d0
          velzr = 0.d0
          templ = 8.0d0
          tempr = 0.6d0
          yel = 0.48d0
          yer = 0.48d0
        else
          call CCTK_WARN(0,"Shock case not recognized")
        end if

        if ( ((change_shock_direction==0).and.(direction .lt. 0.0d0)).or.& 
             ((change_shock_direction==1).and.(direction .gt. 0.0d0)) ) then
          rho(i,j,k) = rhol
          velx(i,j,k) = velxl
          vely(i,j,k) = velyl
          velz(i,j,k) = velzl
          temperature(i,j,k) = templ
          y_e(i,j,k) = yel
        else
          rho(i,j,k) = rhor
          velx(i,j,k) = velxr
          vely(i,j,k) = velyr
          velz(i,j,k) = velzr
          temperature(i,j,k) = tempr
          y_e(i,j,k) = yer
        end if

        det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))

        ! call EOS with
        keytemp = 1
        call EOS_Omni_press(handle,keytemp,GRHydro_eos_rf_prec,n,&
             rho(i,j,k),eps(i,j,k),temperature(i,j,k),y_e(i,j,k),press(i,j,k),keyerr,anyerr)

        if(anyerr.ne.0) then
           call CCTK_WARN(1,"Error in Initial Data EOS call!")
           write(warnline,"(A10,i8)") "keyerr= ",keyerr
           call CCTK_WARN(0,warnline)
        endif

        ! set up conserved variables
        w = 1.0d0 / &
             sqrt(1.0d0 - (gxx(i,j,k)*vel(i,j,k,1)*vel(i,j,k,1) &
                + gyy(i,j,k)*vel(i,j,k,2)*vel(i,j,k,2) &
                + gzz(i,j,k)*vel(i,j,k,3)*vel(i,j,k,3) ) )

        vlowx = gxx(i,j,k)*vel(i,j,k,1) &
             + gxy(i,j,k)*vel(i,j,k,2)  &
             + gxz(i,j,k)*vel(i,j,k,3)
        vlowy = gxy(i,j,k)*vel(i,j,k,1) &
             + gyy(i,j,k)*vel(i,j,k,2)  &
             + gyz(i,j,k)*vel(i,j,k,3)
        vlowz = gxz(i,j,k)*vel(i,j,k,1) &
             + gyz(i,j,k)*vel(i,j,k,2)  &
             + gzz(i,j,k)*vel(i,j,k,3)


        dens(i,j,k) = sqrt(det)*w*rho(i,j,k)

        tenthalpy = 1.0d0 + eps(i,j,k) + press(i,j,k) / rho(i,j,k)

        tau(i,j,k) = sqrt(det)*( (rho(i,j,k)*(1.0d0+eps(i,j,k))+press(i,j,k))*w*w - press(i,j,k)) &
             - dens(i,j,k)

        w_lorentz(i,j,k) = w

        scon(i,j,k,1) = sqrt(det)*rho(i,j,k)*tenthalpy*(w**2) &
             *vlowx
        scon(i,j,k,2) = sqrt(det)*rho(i,j,k)*tenthalpy*(w**2) &
             *vlowy
        scon(i,j,k,3) = sqrt(det)*rho(i,j,k)*tenthalpy*(w**2) &
             *vlowz
        
        Y_e_con(i,j,k) = dens(i,j,k)*Y_e(i,j,k)
           
     enddo
    enddo
  enddo

  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0

  return
  
end subroutine GRHydro_shocktube_hot

```

GRHydro_AdvectedLoopM.F90:
```
 /*@@
   @file      GRHydro_AdvectedLoopM.F90
   @date      Aug 15, 2011
   @author    Scott Noble, Joshua Faber, Bruno Mundim
   @desc 
   Advected loop test as implemented by Beckwith and Stone Astrophys.J.Suppl. 
   193 (2011) 6,  arXiv:1101.3573. 


   Other relevant references: Devore JCP 92, 142 (1991), 
                              Toth and Odstrcil JCP 128,82 (1996),
                              Gardiner and Stone JCP 227, 4123 (2008);
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "GRHydro_Macros.h"

#define velx(i,j,k) vel(i,j,k,1)
#define vely(i,j,k) vel(i,j,k,2)
#define velz(i,j,k) vel(i,j,k,3)
#define sx(i,j,k) scon(i,j,k,1)
#define sy(i,j,k) scon(i,j,k,2)
#define sz(i,j,k) scon(i,j,k,3)
#define Bvecx(i,j,k) Bvec(i,j,k,1)
#define Bvecy(i,j,k) Bvec(i,j,k,2)
#define Bvecz(i,j,k) Bvec(i,j,k,3)
#define Bconsx(i,j,k) Bcons(i,j,k,1)
#define Bconsy(i,j,k) Bcons(i,j,k,2)
#define Bconsz(i,j,k) Bcons(i,j,k,3)


 /*@@
   @routine    GRHydro_AdvectedLoopM
   @date       Aug 11, 2011
   @author     Scott Noble, Joshua Faber, Bruno Mundim
   @desc 
   Initial data for advected loop test
   @enddesc 
   @calls     
   @calledby   
   @history 
   Using GRHydro_ShockTubeM.F90 as a template.
   @endhistory 

@@*/

subroutine GRHydro_AdvectedLoopM(CCTK_ARGUMENTS)

  implicit none
  
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS
  
  CCTK_INT :: i, j, k, nx, ny, nz
  CCTK_REAL :: det,radius,vxval,vyval,vzval,gam
  CCTK_REAL :: radius_iph, radius_imh 
  CCTK_REAL :: radius_jph, radius_jmh 
  CCTK_REAL :: radius_kph, radius_kmh 
  CCTK_REAL :: rhoval,pressval
  CCTK_REAL :: r_loop,A_loop,pi
  CCTK_REAL :: dx,dy,dz
  CCTK_REAL :: range_x,range_y,range_z,range_d
  CCTK_REAL :: cos_theta, sin_theta, tan_theta
  CCTK_REAL :: Bvecx_d, Bvecy_d, Bvecz_d
  CCTK_REAL :: x_d, y_d, z_d,diaglength
  CCTK_REAL :: dx_d, dy_d, dz_d, dx_x, dz_x

!!$Adiabatic index for test:
  gam = (5.0d0/3.0d0)
  
!!$radius of the loop: 
  r_loop = 0.3d0

!!$ stregth of the A-field
  A_loop=1.0d-3

!!$pressure and density:
  rhoval   = 1.0d0
  pressval = 3.0d0

  if (CCTK_EQUALS(advectedloop_type,"2D")) then


!!$ Vx, Vy and Vz values:
    if (CCTK_EQUALS(advectedloop_case,"V^z/=0")) then

!!$vxval=0.2d0/sqrt(6.0d0)
!!$ This new choice yields a crossing time of exactly t=24
!!$ assuming -1<x<1; -0.5<y<0.5
     vxval=1.d0/12.d0
     vyval=0.5d0*vxval
     vzval=vyval

    else if (CCTK_EQUALS(advectedloop_case,"V^z=0")) then
!!$   vxval=0.2d0/sqrt(6.0d0)
     vxval=1.d0/12.d0
     vyval=0.5d0*vxval
     vzval=0.0d0
    else
     call CCTK_WARN(0,"V^z component case not recognized!")
    end if 
    
  else if (CCTK_EQUALS(advectedloop_type,"3D")) then

     vxval=0.2d0*sqrt(2.0d0)
     vyval=0.2d0

    if (CCTK_EQUALS(advectedloop_case,"V^z/=0")) then

!!$vxval=0.2d0/sqrt(6.0d0)
!!$ This new choice yields a crossing time of exactly t=5
!!$ assuming -1<x<1; -0.5<y<0.5
     vzval=0.1

   else if (CCTK_EQUALS(advectedloop_case,"V^z=0")) then
     vzval=0.0d0
    else
     call CCTK_WARN(0,"V^z component case not recognized!")
    end if 

  endif
  nx = cctk_lsh(1)
  ny = cctk_lsh(2)
  nz = cctk_lsh(3)

  dx = CCTK_DELTA_SPACE(1)
  dy = CCTK_DELTA_SPACE(2)
  dz = CCTK_DELTA_SPACE(3)

!!$ Note that the 3D test wasn't deviced to be used with AMR!
  range_x = (cctk_gsh(1)-2*cctk_nghostzones(1))*dx
  range_y = (cctk_gsh(2)-2*cctk_nghostzones(2))*dy
  range_z = (cctk_gsh(3)-2*cctk_nghostzones(3))*dz

  range_d = sqrt(range_z**2+range_x**2)
  diaglength = range_x*range_z/range_d

!!$ For 3-d case, the grid is going to be assumed to be a cube

  cos_theta = range_z/range_d
  sin_theta = range_x/range_d
  tan_theta = sin_theta/cos_theta
  
  do i=1,nx
     do j=1,ny
        do k=1,nz

           rho(i,j,k)=rhoval
           press(i,j,k)=pressval
           eps(i,j,k)=press(i,j,k)/(gam-1.0d0)/rho(i,j,k)

           if (CCTK_EQUALS(advectedloop_type,"2D")) then
             velx(i,j,k)=vxval
             vely(i,j,k)=vyval
             velz(i,j,k)=vzval
             Bvecz(i,j,k)=0.0d0

             radius = sqrt(x(i,j,k)**2+y(i,j,k)**2)
  
             if (CCTK_EQUALS(advectedloop_delA,"Exact")) then
    
               if(radius.le.r_loop) then
                  Bvecx(i,j,k)=-1.0d0*A_loop*y(i,j,k)/radius
                  Bvecy(i,j,k)=A_loop*x(i,j,k)/radius
               else
                  Bvecx(i,j,k)=0.0d0
                  Bvecy(i,j,k)=0.0d0
               endif

             else if (CCTK_EQUALS(advectedloop_delA,"Numeric")) then
  
               radius_iph = max(sqrt((x(i,j,k)+0.5d0*dx)**2+y(i,j,k)**2)-r_loop,0.d0)
               radius_imh = max(sqrt((x(i,j,k)-0.5d0*dx)**2+y(i,j,k)**2)-r_loop,0.d0)
               radius_jph = max(sqrt(x(i,j,k)**2+(y(i,j,k)+0.5d0*dy)**2)-r_loop,0.d0)
               radius_jmh = max(sqrt(x(i,j,k)**2+(y(i,j,k)-0.5d0*dy)**2)-r_loop,0.d0)

!!               if(radius.le.r_loop) then
                  Bvecx(i,j,k)=-1.0d0*A_loop*(radius_jph-radius_jmh)/dy
                  Bvecy(i,j,k)=A_loop*(radius_iph-radius_imh)/dx
!!               else
!!                  Bvecx(i,j,k)=0.0d0
!!                  Bvecy(i,j,k)=0.0d0
!!               endif

             else
               call CCTK_WARN(0,"A^b differentiation not recognized!")
             end if 

           else if (CCTK_EQUALS(advectedloop_type,"3D")) then


!!$  tangential velocity should be parallel to (1,1,1) plus a normal component (-1,0,1)

             velx(i,j,k)=cos_theta*vxval-sin_theta*vzval
             vely(i,j,k)=vyval
             velz(i,j,k)=cos_theta*vzval+sin_theta*vxval

             Bvecz_d=0.0d0

!!$ x_d = (x+z)/sqrt(2) => x_d=0 is equivalent to x+z=0

             x_d = cos_theta*x(i,j,k)+sin_theta*z(i,j,k)
             y_d = y(i,j,k)
             z_d = cos_theta*z(i,j,k)-sin_theta*x(i,j,k)
          
!!$ need to make x_d periodic!

             if(x_d.gt.1.5*diaglength) then
                x_d=x_d-2.0*diaglength
             else if (x_d.gt.0.5*diaglength .and. x_d.lt.1.5*diaglength) then
                x_d=x_d-diaglength
             else if(x_d.lt.-1.5*diaglength) then
                x_d=x_d+2.0*diaglength
             else if (x_d.lt.(-0.5*diaglength) .and. x_d.gt.(-1.5*diaglength)) then
                x_d=x_d+diaglength
             endif

             radius = sqrt(x_d**2+y_d**2)
  
             if (CCTK_EQUALS(advectedloop_delA,"Exact")) then
    
               if(radius.le.r_loop) then
                  Bvecx_d=-1.0d0*A_loop*y_d/radius
                  Bvecy_d=A_loop*x_d/radius
               else
                  Bvecx_d=0.0d0
                  Bvecy_d=0.0d0
               endif

               Bvecx(i,j,k)=cos_theta*Bvecx_d-sin_theta*Bvecz_d
               Bvecy(i,j,k)=Bvecy_d
               Bvecz(i,j,k)=cos_theta*Bvecz_d+sin_theta*Bvecx_d

             else if (CCTK_EQUALS(advectedloop_delA,"Numeric")) then

!!               dx_d = cos_theta*dx+sin_theta*dz
!!               dy_d = dy
!!               dz_d = cos_theta*dz-sin_theta*dx

!!  dx_d is the change in the rotated coords induced by a step in a direction over the Cartesian grid
                dx_x = cos_theta*dx
                dz_x = sin_theta*dz

!!  These are used for exact differencing
               radius_iph = max(sqrt((x_d+0.5d0*dx_x)**2+y_d**2)-r_loop,0.d0)
               radius_imh = max(sqrt((x_d-0.5d0*dx_x)**2+y_d**2)-r_loop,0.d0)
               radius_jph = max(sqrt(x_d**2+(y_d+0.5d0*dy)**2)-r_loop,0.d0)
               radius_jmh = max(sqrt(x_d**2+(y_d-0.5d0*dy)**2)-r_loop,0.d0)
               radius_kph = max(sqrt((x_d+0.5d0*dz_x)**2+y_d**2)-r_loop,0.d0)
               radius_kmh = max(sqrt((x_d-0.5d0*dz_x)**2+y_d**2)-r_loop,0.d0)

!! see notes
!!               if(radius.le.r_loop) then
                  Bvecx(i,j,k)=-1.0d0*A_loop*cos_theta*(radius_jph-radius_jmh)/dy
                  Bvecy(i,j,k)=A_loop*(sin_theta*(radius_kph-radius_kmh)/dz + &
                       cos_theta*(radius_iph-radius_imh)/dx)
                  Bvecz(i,j,k)=-1.0d0*A_loop*sin_theta*(radius_jph-radius_jmh)/dy
!!               else
!!                  Bvecx(i,j,k)=0.0d0
!!                  Bvecy(i,j,k)=0.0d0
!!                  Bvecz(i,j,k)=0.0d0
!!               endif

             else
               call CCTK_WARN(0,"A^b differentiation not recognized!")
             end if 

           else
             call CCTK_WARN(0,"Advected loop type not recognized!")
           end if 
           
           det=SPATIAL_DETERMINANT(gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k))
           
           if (CCTK_EQUALS(GRHydro_eos_type,"Polytype")) then
              call Prim2ConPolyM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
                   gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
                   det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
                   tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
                   velx(i,j,k),vely(i,j,k),velz(i,j,k),&
                   eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
                   w_lorentz(i,j,k))
           else
              call Prim2ConGenM(GRHydro_eos_handle,gxx(i,j,k),gxy(i,j,k),&
                   gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k),&
                   det, dens(i,j,k),sx(i,j,k),sy(i,j,k),sz(i,j,k),&
                   tau(i,j,k),Bconsx(i,j,k),Bconsy(i,j,k),Bconsz(i,j,k),rho(i,j,k),&
                   velx(i,j,k),vely(i,j,k),velz(i,j,k),&
                   eps(i,j,k),press(i,j,k),Bvecx(i,j,k),Bvecy(i,j,k),Bvecz(i,j,k),&
                   w_lorentz(i,j,k))
           end if
           
        enddo
     enddo
  enddo
  
  densrhs = 0.d0
  srhs = 0.d0
  taurhs = 0.d0
  Bconsrhs = 0.d0

  return
  
end subroutine GRHydro_AdvectedLoopM



```

GRHydro_P2C2PM_eosomni.F90:
```
 /*@@
   @file      GRHydro_P2C2PM.F90
   @date      Sep 25, 2010
   @author    Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   A test of the conservative <--> primitive variable exchange
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"

 /*@@
   @routine    p2c2pm
   @date       Sep 25, 2010
   @author     Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   Testing the conservative <--> primitive variable transformations.
   The values before and after should match.
   @enddesc 
   @calls     
   @calledby   
   @history 
 
   @endhistory 

@@*/

subroutine p2c2pm(CCTK_ARGUMENTS)

  implicit none

  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS

  CCTK_REAL :: det
  CCTK_REAL :: uxx,uxy,uxz,uyy,uyz,uzz
  CCTK_REAL :: gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send
  CCTK_REAL :: dens_send,sx_send,sy_send,sz_send,tau_send
  CCTK_REAL :: bconsx_send,bconsy_send,bconsz_send
  CCTK_REAL :: rho_send(1),velx_send,vely_send,velz_send,eps_send(1)
  CCTK_REAL :: press_send(1),w_lorentz_send,x_send,y_send,z_send,r_send
  CCTK_REAL :: bvcx_send,bvcy_send,bvcz_send,b2_send
  CCTK_REAL :: C2P_failed
  CCTK_INT :: epsnegative

! begin EOS Omni vars
  CCTK_REAL :: pmin(1), epsmin(1), local_gam(1), epsval(1)
  CCTK_INT :: n,keytemp,anyerr,keyerr(1)
  CCTK_REAL :: xpress(1),xtemp(1),xye(1),xeps(1),xrho(1)
  n=1;keytemp=0;anyerr=0;keyerr(1)=0
  xpress(1)=0.0d0;xtemp(1)=0.0d0;xye(1)=0.0d0;xeps(1)=0.0d0
! end EOS Omni vars

  call CCTK_WARN(1,"This test works only with Ideal_Fluid EoS")
  
  x_send = 0.0d0
  y_send = 0.0d0
  z_send = 0.0d0
  r_send = 0.0d0
  
  gxx_send = 1.0d0
  gyy_send = 1.0d0 
  gzz_send = 1.0d0
  gxy_send = 0.0d0
  gxz_send = 0.0d0
  gyz_send = 0.0d0
  
  det = 1.0d0
  
  uxx = 1.0d0
  uyy = 1.0d0 
  uzz = 1.0d0
  uxy = 0.0d0
  uxz = 0.0d0
  uyz = 0.0d0
  
  rho_send = 1.29047362d0
  velx_send   = 0.166666658d0
  vely_send   = 0.166666658d0
  velz_send   = 0.166666658d0
  eps_send  = 0.484123939d0
  
  bvcx_send   = Bx_init
  bvcy_send   = By_init
  bvcz_send   = Bz_init
  bconsx_send   = Bx_init
  bconsy_send   = By_init
  bconsz_send   = Bz_init

  w_lorentz_send = 1.d0/sqrt(1.0d0-velx_send*velx_send-vely_send*vely_send-velz_send*velz_send)

  epsnegative = 0
  
  xrho = 1.0d-10
  epsval = 1.0d0

  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       rho_send,eps_send,xtemp,xye,press_send,keyerr,anyerr)
  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,epsval,xtemp,xye,pmin,keyerr,anyerr)

  call EOS_Omni_EpsFromPress(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,xeps,xtemp,xye,pmin,epsmin,keyerr,anyerr)

  local_gam = 0.0d0
  xrho = 1.0d0
  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,epsval,xtemp,xye,local_gam,keyerr,anyerr)
  local_gam = local_gam + 1.0

  C2P_failed = 0.0d0

  write(*,*) 'P2C2PM test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   W     : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  write(*,*) 'P2C2PM test: converting back to conserved variables.'
  call Prim2ConGenM(GRHydro_eos_handle,&
       gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,det, &
       dens_send,sx_send,sy_send,sz_send,tau_send, &
       bconsx_send,bconsy_send,bconsz_send, &
       rho_send(1),velx_send,vely_send,velz_send,eps_send(1),press_send(1), &
       bvcx_send,bvcy_send,bvcz_send,w_lorentz_send) 

  write(*,*) 'P2C2PM test: initial values.'
  write(*,*) '   conservative variables: '
  write(*,*) '   dens: ',dens_send
  write(*,*) '   sx  : ',sx_send
  write(*,*) '   sy  : ',sy_send
  write(*,*) '   sz  : ',sz_send
  write(*,*) '   tau : ',tau_send
  write(*,*) '   Bconsx  : ',bconsx_send
  write(*,*) '   Bconsy  : ',bconsy_send
  write(*,*) '   Bconsz  : ',bconsz_send
  write(*,*) '   eps : ',eps_send
  write(*,*) '   W   : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  write(*,*) 'P2C2PM test: getting the associated primitive variables.'
  
!!  call Con2PrimGenM(GRHydro_eos_handle,local_gam(1),dens_send,sx_send,sy_send,sz_send, &
 !!      tau_send,bconsx_send,bconsy_send,bconsz_send,&
 !!      rho_send(1),velx_send,vely_send,velz_send, &
 !!      eps_send(1),press_send(1), &      
 !!      bvcx_send,bvcy_send,bvcz_send,b2_send,&
 !!      w_lorentz_send, &
 !!      gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,&
 !!      uxx,uxy,uxz,uyy,uyz,uzz,det,&
 !!      epsnegative,C2P_failed)
  
  write(*,*) 'P2C2PM test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   W     : ',w_lorentz_send
  write(*,*) '   Bvecx  : ',bvcx_send
  write(*,*) '   Bvecy  : ',bvcy_send
  write(*,*) '   Bvecz  : ',bvcz_send
  
  STOP

  return

end subroutine p2c2pm

```


combined_doc_context: ## README (README):
```
Cactus Code Thorn GRHydro_Init_Data  
Author(s)    : Luca Baiotti
               Ian Hawke
               Scott Hawley
               Frank Löffler
               Christian David Ott
Maintainer(s): CIGR developers team
Licence      : GPLv2+
--------------------------------------------------------------------------

1. Purpose

Provides simple initial data (shock tubes, ...) for the GRHydro code.


```

## Documentation (.tex files):
Files: documentation.tex

```tex
=== documentation.tex ===
\documentclass{article}

\begin{document}

\title{GRHydro\_Init\_Data}
\author{Luca Baiotti, Ian Hawke, Scott Hawley}
\date{24/07/2008}
\maketitle

% Do not delete next line
% START CACTUS THORNGUIDE

\abstract{GRHydro\_Init\_Data - some initial data for {\tt GRHydro}}

\section{Introduction}
\label{sec:intro}

This thorn generates some initial data for the GRHydro code. There are more (and more physically
interesting) initial-data codes in other thorns. As with the GRHydro code itself, please feel free to
add, alter or extend any part of this code. However please keep the documentation up to date (even,
or especially, if it's just to say what doesn't work).

Currently this thorn contains a few tests that should really be test suites, some shock-tube
initial data, 
%some (largely untested and unmaintained; please use the TOV initial-data codes in the
%dedicated thorns) TOV initial data solver routines, 
a routine to set atmopshere everywhere on the
grid (for tests), a routine to read initial data from files (not very generic, tough) and a routine
to set up the simple-wave initial data .


\subsection{Tests}
\label{sec:tests}

There are tests of the TVD reconstruction routine and of the routines
that convert between conservative and primitive variables. These all
just produce output to the screen or to {\tt fort.*} files. The
reconstruction test outputs the function to be reconstructed and the
boundary-extended values. The conservative-to-primitive test just
outputs the two sets of variables. If you haven't altered the code an if you set
\begin{verbatim}
eos_polytrope::eos_gamma =   2.0
eos_polytrope::eos_k     = 100.0
\end{verbatim}
(which are the defaults), the output should be
% I checked that in 2008 the number were still right (but one gets them with eos_gamma=2.0 and 
% eos_k ~ 0.1865) and committed the new ones for the default eos parameter values.

\begin{verbatim}
    primitive variables: 
    rho   :   1.29047172182043     
    velx  :   9.902578465178671E-004
    vely  :   9.902578465178671E-004
    velz  :   9.902578465178671E-004
    eps   :   0.374770481293314     
    press : 166.531726481819     
    w_lor :   1.00000147091915  
\end{verbatim}
The conservative to primitive to conservative test outputs the initial
and final data which should agree.

\subsection{Shocktube tests}
\label{sec:shock}

There are three possible shock-tube problems, referred to as {\tt Sod},
{\tt Simple} and {\tt Blast}, with initial data
\begin{center}
  \begin{tabular}[c]{|c|c|c|c|c|c|c|}
    \hline Type & $\rho_{_L}$ & $v^i_{_L}$ & $\varepsilon_{_L}$ & $\rho_{_R}$ & $v^i_{_R}$
    & $\varepsilon_{_R}$ \\ \hline
    Sod & 1 & 0 & 1.5 & 0.125 & 0 & 0.15 \\
    Simple & 10 & 0 & 20 & 1 & 0 & $10^{-6}$ \\
    Blast & 1 & 0 & 1500 & 1 & 0 & $1.5\cdot 10^{-2}$ \\ \hline
  \end{tabular}
\end{center}
The shock shape can be planar (along each axis or along the main diagonal) or spherical and the
position of the plane or of the center of the sphere can be chosen though parameters.
If a diagonal shock is selected, the initial data is set to either the left or right
state depending on where the centre of the cell falls. Cleverer
routines that weight the initial data to avoid ``staircasing'' may be
added if there is demand. For more discussion on shock tubes
see~\cite{livrevsrrfd}. 


%\subsection{TOV stars}
%\label{sec:tov}
%
%The Tolman-Oppenheimer-Volkoff solution is a spherically symmetric
%fluid ball matched to a Schwarzschild exterior. Typically an
%atmosphere is placed in the exterior to stop the equations of motion
%of the fluid being singular. Given an equation of state, the central
%density $\rho_c$ is specified. Then the solution is found by
%integrating the radial equations
%\begin{eqnarray}
%  \label{eq:tov}
%  \frac{\partial P(r)}{\partial r} & = & - \frac{(\rho + \rho \epsilon
%  + P)(m + 4\pi r^3 P)}{r (r - 2m)} \\
%  \frac{\partial (\log \alpha (r))}{\partial r} & = & \frac{m + 4 \pi
%  r^3 P}{r (r - 2m)} \\
%  \frac{\partial m(r)}{\partial r} & = & 4 \pi r^2 (\rho + \rho
%  \epsilon) \\ 
%  \gamma_{rr}(r) & = & \left( 1-\frac{2m(r)}{r} \right)^{-1},
%\end{eqnarray}
%where $m$ is the mass energy contained in a sphere radius $r$,
%$\gamma_{ij}$ the 3-metric, and $\alpha$ the lapse in standard
%Schwarzschild like coordinates. For more details see~\cite{hydro1}. 
%
%The routines here, written by Scott Hawley, use the LSODA library to
%integrate the equations and then interpolate onto the Cartesian
%grid. 
%
%This routine is untested and unmaintained: please use other thorns providing TOV initial data. They
%are located in dedicated thorns of this arrangement.

\subsection{Only atmosphere}
\label{sec:only-atmo}

For testing purposes, this routine sets all the points to the values of the atmosphere.


\subsection{Simple wave}
\label{sec:simple-wave}

This routine testes initial data for a simple wave with sinusoidal initial function for the velocity,
as described in Anile, Miller, Motta, {\it Formation and damping of relativistic strong
  shocks},Phys. Fluids {\bf 26}, 1450 (1983).



\begin{thebibliography}{1}

\bibitem{livrevsrrfd}
J.~M. Mart{\'{\i}} and E.~M{\"u}ller.
\newblock Numerical hydrodynamics in {S}pecial {R}elativity.
\newblock {\em Living Rev. Relativity}, {\bf 3}, 1999.
\newblock [Article in online journal], cited on 31/7/01,
  http://www.livingreviews.org/Articles/Volume2/1999-3marti/index.html.

\bibitem{hydro1}
J.~A. Font, M. Miller, W. Suen and M. Tobias.
\newblock Three Dimensional Numerical General Relativistic
Hydrodynamics I: Formulations, Methods, and Code Tests
\newblock {\em Phys. Rev.}, {\bf D61}, 044011, 2000.

\end{thebibliography}

% Do not delete next line
% END CACTUS THORNGUIDE

\end{document}



```



Reference solution:
src_code:  /*@@
   @file      GRHydro_P2C2P.F90
   @date      Sep 25, 2010
   @author    Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   A test of the conservative <--> primitive variable exchange
   @enddesc 
 @@*/

#include "cctk.h"
#include "cctk_Parameters.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"

 /*@@
   @routine    p2c2p
   @date       Sep 25, 2010
   @author     Joshua Faber, Scott Noble, Bruno Mundim, Luca Baiotti
   @desc 
   Testing the conservative <--> primitive variable transformations.
   The values before and after should match.
   @enddesc 
   @calls     
   @calledby   
   @history 
 
   @endhistory 

@@*/

subroutine p2c2p(CCTK_ARGUMENTS)

  implicit none

  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS

  CCTK_REAL :: det
  CCTK_REAL :: uxx,uxy,uxz,uyy,uyz,uzz
  CCTK_REAL :: gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send
  CCTK_REAL :: dens_send,sx_send,sy_send,sz_send,tau_send
  CCTK_REAL :: rho_send(1),velx_send,vely_send,velz_send,eps_send(1)
  CCTK_REAL :: press_send(1),w_lorentz_send,x_send,y_send,z_send,r_send
  CCTK_REAL :: C2P_failed
  CCTK_INT :: epsnegative

! begin EOS Omni vars
  CCTK_REAL :: pmin(1), epsmin(1), epsval(1)
  CCTK_INT :: n,keytemp,anyerr,keyerr(1)
  CCTK_REAL :: xpress(1),xtemp(1),xye(1),xeps(1),xrho(1)
  n=1;keytemp=0;anyerr=0;keyerr(1)=0
  xpress(1)=0.0d0;xtemp(1)=0.0d0;xye(1)=0.0d0;xeps(1)=0.0d0
! end EOS Omni vars

  call CCTK_WARN(1,"This test works only with Ideal_Fluid EoS")
  
  x_send = 0.0d0
  y_send = 0.0d0
  z_send = 0.0d0
  r_send = 0.0d0
  
  gxx_send = 1.0d0
  gyy_send = 1.0d0 
  gzz_send = 1.0d0
  gxy_send = 0.0d0
  gxz_send = 0.0d0
  gyz_send = 0.0d0
  
  det = 1.0d0
  
  uxx = 1.0d0
  uyy = 1.0d0 
  uzz = 1.0d0
  uxy = 0.0d0
  uxz = 0.0d0
  uyz = 0.0d0
  
  rho_send = 1.29047362d0
  velx_send   = 0.166666658d0
  vely_send   = 0.166666658d0
  velz_send   = 0.166666658d0
  eps_send  = 0.484123939d0
  
  w_lorentz_send = 1.d0/sqrt(1.0d0-velx_send*velx_send-vely_send*vely_send-velz_send*velz_send)

  epsnegative = 0
  
  xrho = 1.0d-10
  epsval = 1.0d0

  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       rho_send,eps_send,xtemp,xye,press_send,keyerr,anyerr)
  call EOS_Omni_press(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,epsval,xtemp,xye,pmin,keyerr,anyerr)

  call EOS_Omni_EpsFromPress(GRHydro_eos_handle,keytemp,GRHydro_eos_rf_prec,n,&
       xrho,xeps,xtemp,xye,pmin,epsmin,keyerr,anyerr)

  C2P_failed = 0.0d0

  write(*,*) 'P2C2P test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   W     : ',w_lorentz_send
  
  write(*,*) 'P2C2P test: converting back to conserved variables.'
  call Prim2ConGen(GRHydro_eos_handle, &
       gxx_send,gxy_send,gxz_send,gyy_send,gyz_send,gzz_send,det, &
       dens_send,sx_send,sy_send,sz_send,tau_send,rho_send(1), &
       velx_send,vely_send,velz_send,eps_send(1),press_send(1),w_lorentz_send) 

  write(*,*) 'P2C2P test: initial values.'
  write(*,*) '   conservative variables: '
  write(*,*) '   dens: ',dens_send
  write(*,*) '   sx  : ',sx_send
  write(*,*) '   sy  : ',sy_send
  write(*,*) '   sz  : ',sz_send
  write(*,*) '   tau : ',tau_send
  write(*,*) '   eps : ',eps_send
  write(*,*) '   W   : ',w_lorentz_send
  
  write(*,*) 'P2C2P test: getting the associated primitive variables.'
  call Con2PrimGen(GRHydro_eos_handle,dens_send,sx_send,sy_send,sz_send, &
       tau_send,rho_send(1),velx_send,vely_send,velz_send, &
       eps_send(1),press_send(1),w_lorentz_send, &
       uxx,uxy,uxz,uyy,uyz,uzz,det,x_send,y_send,z_send,r_send,&
       epsnegative,xrho(1),pmin(1),epsmin(1),GRHydro_init_data_reflevel,C2P_failed)
  
  write(*,*) 'P2C2P test: the primitive variables are'
  write(*,*) '   primitive variables: '
  write(*,*) '   rho   : ',rho_send
  write(*,*) '   velx  : ',velx_send
  write(*,*) '   vely  : ',vely_send
  write(*,*) '   velz  : ',velz_send
  write(*,*) '   press : ',press_send
  write(*,*) '   eps   : ',eps_send
  write(*,*) '   W     : ',w_lorentz_send
  
  STOP

  return

end subroutine p2c2p