Task: Implement psi_1st_deriv.x for EinsteinInitialData/IDAxiBrillBH thorn

thorn_name: EinsteinInitialData/IDAxiBrillBH
src_filename: psi_1st_deriv.x
interface: # Interface definition for thorn IDAxiBrillBH
# $Header$

implements: idaxibrillbh
inherits: ADMBase grid StaticConformal

public:

#
# functions from StaticConformal
#
void FUNCTION ConfToPhysInPlace (CCTK_INT IN nx,            \
                                 CCTK_INT IN ny,            \
                                 CCTK_INT IN nz,            \
                                 CCTK_REAL ARRAY IN psi,    \
                                 CCTK_REAL ARRAY INOUT gxx, \
                                 CCTK_REAL ARRAY INOUT gxy, \
                                 CCTK_REAL ARRAY INOUT gxz, \
                                 CCTK_REAL ARRAY INOUT gyy, \
                                 CCTK_REAL ARRAY INOUT gyz, \
                                 CCTK_REAL ARRAY INOUT gzz)
uses function ConfToPhysInPlace

schedule: # Schedule definitions for thorn IDAxiBrillBH
# $Header$

if (CCTK_Equals(initial_data,"axibrillbh")) 
{
  schedule IDAxiBrillBH_ParamChecker at CCTK_PARAMCHECK
  {
    LANG: C
    OPTIONS: global
  } "Check that the metric_type is recognised"

  schedule IDAxiBrillBH in ADMBase_InitialData
  {
    LANG: Fortran
    STORAGE: StaticConformal::confac
    STORAGE: StaticConformal::confac_1derivs
    STORAGE: StaticConformal::confac_2derivs
  } "Construct IDAxiBrillBH"  
}

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

shares: ADMBase

EXTENDS KEYWORD initial_lapse 
{
  "schwarz" :: "Set lapse to Schwarzschild"
}

EXTENDS KEYWORD initial_data 
{
   "axibrillbh" :: "Axisymmetry Initial data for Black hole + Brill wave"
}

USES KEYWORD metric_type


private:

############################################################

#
# ***** debugging parameters *****
#

#
# If this parameter is set to true, we output an ASCII data file
# giving psi on the 2D grid.  The file format should be directly usable
# by a gnuplot 'splot' command.
#
Boolean output_psi2D							\
  "should we output the conformal factor psi on the 2D grid?"
{
} false

string output_psi2D_file_name						\
  "if we output the conformal factor psi on the 2D grid,		\
   what file name should we use for the output file?"
{
".+" :: "any non-empty string that's a valid file name"
} "psi2D.dat"

#
# this parameter controls the amount of (potentially very detailed)
# debugging information this thorn prints
#
CCTK_INT debug                                                          \
  "level of debugging information to print                              \
   (0 = none, 2 = a little, 6 = a lot, 10 = huge amounts)"
{
0:* :: "any integer >= 0"
} 0

#
# to keep the output size quasi-finite, some debug printing which is
# logicially "per grid point" on the 2-D (eta,q) grid, is actually only
# done for this single 2-D grid point
#
CCTK_INT debug_ii "i coordinate for per-2D-grid-point debug printing"
{
*:* :: "any integer"
} 14
CCTK_INT debug_jj "j coordinate for per-2D-grid-point debug printing"
{
*:* :: "any integer"
} 15

#
# to keep the output size quasi-finite, some debug printing which is
# logicially "per Cactus grid point" is actually only done for this single
# Cactus grid point
#
CCTK_INT debug_i "i coordinate for per-grid-point debug printing"
{
*:* :: "any integer"
} 14
CCTK_INT debug_j "j coordinate for per-grid-point debug printing"
{
*:* :: "any integer"
} 15
CCTK_INT debug_k "k coordinate for per-grid-point debug printing"
{
*:* :: "any integer"
} 10

############################################################

#
# ***** parameters controlling the Brill wave itself *****
#

REAL amp "Brill wave amplitude"
{
  *:* :: "No restriction"
} 0.1

REAL eta0 "Brill wave center (in eta coords)"
{
  *:* :: "No restriction"
} 0.0

REAL sigma "Brill wave width (in eta)"
{
  *:* :: "No restriction"
} 1.0

REAL etamax "eta value for outer edge of grid"
{
  *:* :: "No restriction"
} 5.0

INT n "sin^n theta in Brill wave"
{
  *:* :: "No restriction"
} 2

############################################################

#
# ***** parameters for the numerical solution of the *****
# ***** Brill-wave equation on the 2-D (eta,q) grid *****
#

INT ne "eta resolution for solve"
{
  *:* :: "No restriction"
} 300

INT nq "theta resolution for solve"
{
  *:* :: "No restriction"
} 50

REAL error_tolerance "tolerance parameter for elliptic solver"
{
(0:* :: "any positive real number"
} 1.0e-12

############################################################

#
# ***** interpolation parameters *****
#

#
# This thorn first computes the Brill wave solution on an internal 2-D
# grid, then interpolates this to the 3-D Cactus grid.  The following
# parameters control this interpolation.
#

STRING interpolator_name \
  "name of CCTK_InterpLocalUniform() interpolation operator"
{
".*" :: "any string"
} "uniform cartesian"

STRING interpolator_pars "parameters for the interpolation operator"
{
".*" :: \
  "any nonempty string acceptable to Util_TableSetFromString()		\
   and to the interpolator, or the empty string to use 'order=n',	\
   where  n  is specified by the  interpolation_order  parameter"
} ""

INT interpolation_order "Order for interpolation" STEERABLE = ALWAYS
{
0:9 :: "any integer accepted by the interpolator"
} 1

############################################################

#
# ***** miscellaneous parameters *****
#

Boolean generate_StaticConformal_metric					\
  "should we generate a StaticConformal conformal metric (true),	\
   or a pure ADMBase physical metric (false)"
{
} true

configuration: # Configuration definition for thorn IDAxiBrillBH

REQUIRES Fortran

context: ParamCheck.c:
```
 /*@@
   @file      ParamCheck.c
   @date      Thu May  2 19:23:47 CEST 2002
   @author    David Rideout
   @desc 
   Check the parameters for IDAxiBrillBH
   @enddesc 
   @version $Header$
 @@*/

#include "cctk.h"

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

static const char *rcsid = "$Header$";

CCTK_FILEVERSION(CactusEinstein_IDAxiBrillBH_ParamCheck_c)

/********************************************************************
 *********************     Local Data Types   ***********************
 ********************************************************************/

/********************************************************************
 ********************* Local Routine Prototypes *********************
 ********************************************************************/

/********************************************************************
 ***************** Scheduled Routine Prototypes *********************
 ********************************************************************/

void IDAxiBrillBH_ParamChecker(CCTK_ARGUMENTS);

/********************************************************************
 ********************* Other Routine Prototypes *********************
 ********************************************************************/

/********************************************************************
 *********************     Local Data   *****************************
 ********************************************************************/

/********************************************************************
 *********************     External Routines   **********************
 ********************************************************************/

void IDAxiBrillBH_ParamChecker(CCTK_ARGUMENTS)
{
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS

  /* Do we know how to deal with this type of metric ? */
  if( ! CCTK_EQUALS(metric_type, "static conformal") &&
      ! CCTK_EQUALS(metric_type, "physical"))
  {
    CCTK_PARAMWARN("Unknown ADMBase::metric_type - known types are \"physical\" and \"static conformal\"");
  }

  /* Report on parameters */
  
  CCTK_INFO("Initial data will be axisymmetric BH+Brill Wave");
  CCTK_VInfo(CCTK_THORNSTRING,"  ... wave amplitude: %f",amp);
  CCTK_VInfo(CCTK_THORNSTRING,"  ... wave center (in eta coords): %f",eta0);
  CCTK_VInfo(CCTK_THORNSTRING,"  ... wave sigma: %f",sigma);
  CCTK_VInfo(CCTK_THORNSTRING,"  ... wave power of sin theta: %d",(int)n);
  CCTK_VInfo(CCTK_THORNSTRING,"  ... outer edge of eta grid: %f",etamax);

}

/********************************************************************
 *********************     Local Routines   *************************
 ********************************************************************/

```

IDAxiBrillBH.F:
```
c/*@@
c  @file      IDAxiBrillBH.F
c  @date
c  @author
c  @desc
c
c  @enddesc
c@@*/

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

c/*@@
c  @routine    IDAxiBrillBH
c  @date
c  @author
c  @desc
c
c  @enddesc
c  @calls
c  @calledby
c  @history
c
c  @endhistory
c@@*/

      subroutine IDAxiBrillBH(CCTK_ARGUMENTS)

      use cctk

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS
      DECLARE_CCTK_FUNCTIONS

      interface
      subroutine mgparm(m,ifd59,id5,id9,idi,idg,imx,jmx)
      implicit CCTK_REAL (a-h,o-z)
      end
      subroutine mg5 (idim,ilower,iupper,jdim,jlower,jupper,
     &     cc,cn,cs,cw,ce,u,rhs,
     &     id5,id9,idi,idg,ifmg,eps,rmax,ier)
      implicit CCTK_REAL (a-h,o-z)
      CCTK_REAL cc(idim,jdim),cn(idim,jdim),cs(idim,jdim),cw(idim,jdim),
     &     ce(idim,jdim),cnw(idim,jdim),cne(idim,jdim),csw(idim,jdim),
     &     cse(idim,jdim),u(idim,jdim),rhs(idim,jdim)
      end
      end interface

      CCTK_REAL, parameter :: one = 1
      CCTK_REAL, parameter :: eps = 1.0e-10
      CCTK_REAL axibheps, rmax, dq, deta
      integer levels,id5,id9,idi,idg,ier
      CCTK_REAL, allocatable :: cc(:,:),ce(:,:),cw(:,:),cn(:,:),cs(:,:),
     $     rhs(:,:),psi2d(:,:),detapsi2d(:,:),dqpsi2d(:,:),
     $     detaetapsi2d(:,:),detaqpsi2d(:,:),dqqpsi2d(:,:)
      CCTK_REAL, allocatable :: etagrd(:),qgrd(:)
      CCTK_REAL, allocatable :: eta(:,:,:),abseta(:,:,:),sign_eta(:,:,:),
     $     q(:,:,:),phi(:,:,:)
      CCTK_REAL, allocatable :: psi2dv(:,:,:),detapsi2dv(:,:,:),
     $     dqpsi2dv(:,:,:),detaetapsi2dv(:,:,:),detaqpsi2dv(:,:,:),
     $     dqqpsi2dv(:,:,:)
      CCTK_REAL error_at_this_grid_point,max_error_in_grid
      CCTK_REAL o1,o2,o3,o4,o5,o6,o7,o8,o9
      CCTK_REAL o10,o11,o12,o13,o14,o15,o16,o17,o18,o19
      CCTK_REAL o20,o21,o22,o23,o24,o25,o26,o27,o28,o29
      CCTK_REAL o30,o31,o32,o33,o34,o35,o36,o37,o38,o39
      CCTK_REAL o40,o41,o42,o43,o44,o45,o46,o47,o48,o49
      CCTK_REAL o50,o51,o52,o53,o54,o55,o56,o57,o58,o59
      CCTK_REAL o60,o61,o62,o63,o64,o65,o66,o67,o68,o69
      CCTK_REAL o70,o71,o72,o73,o74,o75,o76,o77,o78,o79
      CCTK_REAL o80,o81,o82,o83,o84,o85,o86,o87,o88,o89
      CCTK_REAL o90,o91,o92,o93,o94,o95,o96
      integer i22
      CCTK_REAL pi
      CCTK_REAL adm
      CCTK_REAL exp_mhalf_eta, psi3d
      CCTK_INT nx,ny,nz
      integer i,j,k,nquads
      integer npoints,ierror
      integer neb, nqb
      integer posn
      integer io_status

      integer, parameter :: max_string_length = 500

      integer                         param_table_handle, interp_handle
      character(max_string_length) :: message_buffer

      integer                         fstring_length
      character(max_string_length) :: interpolator_name_fstring
      character(max_string_length) :: interpolator_pars_fstring
      character(max_string_length) :: output_psi2D_file_name_fstring

      CCTK_REAL,    dimension(2) :: coord_origin, coord_delta
      CCTK_POINTER, dimension(2) :: interp_coords
      CCTK_POINTER, dimension(6) :: in_arrays, out_arrays
      CCTK_INT,     dimension(2) :: in_array_dims
      CCTK_INT,     dimension(6), parameter :: type_codes = CCTK_VARIABLE_REAL


      pi = 4.0d0*atan(1.0d0)

c     Set up the grid spacings
      nx = cctk_lsh(1)
      ny = cctk_lsh(2)
      nz = cctk_lsh(3)

c
c ***** set up interpolator handle and parameter table *****
c

c
c ... we do this now, rather than waiting till we need them,
c     so any errors (eg user forgot to activate a suitable interpolator thorn)
c     get printed right away, rather than making the user wait for them
c ... n.b. we must first convert our C-style string parameters
c     to Fortran strings
c
      call CCTK_FortranString(fstring_length,
     $                        interpolator_name,
     $                        interpolator_name_fstring)
      call CCTK_InterpHandle(interp_handle,
     $                       interpolator_name_fstring(1:fstring_length))
      if (interp_handle .lt. 0) then
         call CCTK_ERROR("Cannot get interpolator handle!  did you forgot to activate a suitable local-interpolator thorn?")
c     " (fix syntax highlighting)
      endif

c
c build the interpolator parameter table from a suitable string:
c if  interpolator_pars  is a nonempty string, use that, otherwise
c use  "order=n"  where  n  is given by the  interpolation_order
c parameter
c
      call CCTK_FortranString(fstring_length,
     $                        interpolator_pars,
     $                        interpolator_pars_fstring)
      if (fstring_length .eq. 0) then
         interpolator_pars_fstring
     $         = "order=" // char(ichar('0') + interpolation_order)
      endif
      call Util_TableCreateFromString
     $            (param_table_handle,
     $             interpolator_pars_fstring(1:fstring_length))
      if (param_table_handle .lt. 0) then
        write(message_buffer, '(A,I8)')
     $      'failed to create interpolator param table: error code ',
     $      param_table_handle
        call CCTK_WARN(CCTK_WARN_ABORT, message_buffer)
      endif

c
c ***** solve Brill-wave equation on 2D (eta,theta) grid *****
c
c The code uses the abbreviation 'q' for theta.  This is a bit confusing,
c because this is *not* the same quantity as $q(\eta,\theta)$ described
c in the thorn guide (which is is stored in the 3-D array q(nx,ny,nz)).
c
c The (eta,theta) grid spans the range
c	eta   in [0,etamax] + ghost zones   (neb points, spacing deta)
c	theta in [0,pi    ] + ghost zones   (nqb points, spacing dq  )
c
c     2D grid size NE x NQ, plus 2 zones for boundaries
c
c     21/11/00 TR: dont change parameters in place
c                  but keep a copy in local variables
c                  Otherwise the changed parameters cause trouble
c                  after recovery.
c
      neb = ne+2
      nqb = nq+2

      allocate(          cc(neb,nqb))
      allocate(          ce(neb,nqb))
      allocate(          cw(neb,nqb))
      allocate(          cn(neb,nqb))
      allocate(          cs(neb,nqb))
      allocate(         rhs(neb,nqb))
      allocate(       psi2d(neb,nqb))
      allocate(   detapsi2d(neb,nqb))
      allocate(     dqpsi2d(neb,nqb))
      allocate(detaetapsi2d(neb,nqb))
      allocate(  detaqpsi2d(neb,nqb))
      allocate(    dqqpsi2d(neb,nqb))

      allocate(etagrd(neb))
      allocate(  qgrd(nqb))

      allocate(          eta(nx,ny,nz))
      allocate(       abseta(nx,ny,nz))
      allocate(     sign_eta(nx,ny,nz))
      allocate(            q(nx,ny,nz))
      allocate(          phi(nx,ny,nz))
      allocate(       psi2dv(nx,ny,nz))
      allocate(   detapsi2dv(nx,ny,nz))
      allocate(     dqpsi2dv(nx,ny,nz))
      allocate(detaetapsi2dv(nx,ny,nz))
      allocate(  detaqpsi2dv(nx,ny,nz))
      allocate(    dqqpsi2dv(nx,ny,nz))

c Initialize some arrays
      psi2d = 1.0d0
      detapsi2d = 0.0d0

      nquads = 2
      dq = nquads*0.5d0*pi/(nqb-2)
      deta = etamax/(neb-3)

      do j=1,nqb
        qgrd(j) = (j-1.5d0)*dq
        do i=1,neb
          etagrd(i) = (i-2)*deta
#include "EinsteinInitialData/IDAxiBrillBH/src/bhbrill.x"
        enddo
      enddo
c Boundary conditions
      do j=1,nqb
        ce(2,j)=ce(2,j)+cw(2,j)
        cw(2,j)=0.0d0

        cw(neb-1,j)=cw(neb-1,j)+ce(neb-1,j)
        cc(neb-1,j)=cc(neb-1,j)-deta*ce(neb-1,j)
        ce(neb-1,j)=0.0d0

      enddo
      do i=1,neb
        cc(i,2)=cc(i,2)+cs(i,2)
        cs(i,2)=0.0d0
        cc(i,nqb-1)=cc(i,nqb-1)+cn(i,nqb-1)
        cn(i,nqb-1)=0.0d0
      enddo

c Do the solve
      axibheps = error_tolerance
      call CCTK_INFO("Calling axisymmetric solver")

      call mgparm (levels,5,id5,id9,idi,idg,neb,nqb)
      call mg5 (neb,2,neb-1,nqb,2,nqb-1,
     $          cc,cn,cs,cw,ce,psi2d,rhs,
     $          id5,id9,idi,idg,1,axibheps,rmax,ier)

      call CCTK_INFO("Solve complete")

c
c The solution is (hopefully) now available.
c
      if(ier .ne. 0) then
         write(message_buffer, '(A,I8)')
     $      'failed to solve elliptic equation: ier=', ier
         call CCTK_WARN(CCTK_WARN_ABORT, message_buffer)
      end if

      print *,'rmax = ',rmax
      print *,'axibheps = ',axibheps
      print *,'psi2d = ',maxval(psi2d),' ',minval(psi2d)

      max_error_in_grid = 0.0d0
      do j=2,nqb-1
        do i=2,neb-1
          error_at_this_grid_point = rhs(i,j)
     $                               - psi2d(i,j  )*cc(i,j)
     $                               - psi2d(i,j+1)*cn(i,j)
     $                               - psi2d(i,j-1)*cs(i,j)
     $                               - psi2d(i+1,j)*ce(i,j)
     $                               - psi2d(i-1,j)*cw(i,j)
          max_error_in_grid = max(max_error_in_grid,
     $                            abs(error_at_this_grid_point))
        enddo
      enddo
      print *,'Resulting eps =',max_error_in_grid

c Boundary conditions
      do j=1,nqb
         psi2d(1  ,j) = psi2d(3,j)
         psi2d(neb,j) = - deta*psi2d(neb-1,j) + psi2d(neb-2,j)
      enddo

      do i=1,neb
        psi2d(i,1  ) = psi2d(i,2)
        psi2d(i,nqb) = psi2d(i,nqb-1)
      enddo

c derivatives of psi
      do j=2,nqb-1
         do i=2,neb-1
            dqpsi2d  (i,j) = 0.5d0*(psi2d(i,j+1)-psi2d(i,j-1))/dq
            dqqpsi2d (i,j) = (psi2d(i,j+1)+psi2d(i,j-1)-2.0d0*psi2d(i,j))/dq**2
            detapsi2d(i,j) = sinh(0.5d0*etagrd(i))
     $                       + 0.5d0*(psi2d(i+1,j)-psi2d(i-1,j))/deta
            detaetapsi2d(i,j)
     $          = 0.5d0*cosh(0.5d0*etagrd(i))
     $            + (psi2d(i+1,j)+psi2d(i-1,j)-2.0d0*psi2d(i,j))/deta**2
         enddo
      enddo

      do j=1,nqb
        detapsi2d(1,j)=-detapsi2d(3,j)
        detapsi2d(neb,j)=detapsi2d(neb-2,j) ! simplified

        detaetapsi2d(1,j)=detaetapsi2d(3,j)
        detaetapsi2d(neb,j)=detaetapsi2d(neb-2,j) ! simplified...

        dqqpsi2d(1,j)=dqqpsi2d(3,j)
        dqqpsi2d(neb,j)=dqqpsi2d(neb-2,j) ! simplified

        dqpsi2d(1,j)=dqpsi2d(3,j)
        dqpsi2d(neb,j)=-dq*dqpsi2d(neb-1,j)+dqpsi2d(neb-2,j)
      enddo

      do i=1,neb
        detapsi2d(i,1)=detapsi2d(i,2)
        detapsi2d(i,nqb)=detapsi2d(i,nqb-1)

        detaetapsi2d(i,1)=detaetapsi2d(i,2)
        detaetapsi2d(i,nqb)=detaetapsi2d(i,nqb-1)

        dqqpsi2d(i,1)=dqqpsi2d(i,2)
        dqqpsi2d(i,nqb)=dqqpsi2d(i,nqb-1)

        dqpsi2d(i,1)=-dqpsi2d(i,2)
        dqpsi2d(i,nqb)=-dqpsi2d(i,nqb-1)
      enddo

      do j=2,nqb-1
        do i=2,neb-1
          detaqpsi2d(i,j)=0.5d0*(detapsi2d(i,j+1)-detapsi2d(i,j-1))/dq
        enddo
      enddo

      do j=1,nqb
        detaqpsi2d(1,j)=-detaqpsi2d(3,j)
        detaqpsi2d(neb,j)=detaqpsi2d(neb-2,j) ! simplified
      enddo

      do i=1,ne
        detaqpsi2d(i,1)=-detaqpsi2d(i,2)
        detaqpsi2d(i,nqb)=-detaqpsi2d(i,nqb-1)
      enddo

      do j=1,nqb
        psi2d(:,j)=psi2d(:,j)+2.0d0*cosh(0.5d0*etagrd)
      enddo

      if (debug .ge. 6) then
         print *, '### 2-D grid results (= inputs to interpolation) ###'
         print *, 'effective 2-D grid size: neb,nqb =', neb,nqb
         print *, 'debug_{ii,jj} =', debug_ii,debug_jj
         print *, 'at this 2-D grid point...'
         print *, '             eta =', etagrd(debug_ii)
         print *, '       theta [q] =',   qgrd(debug_jj)
         print *, '           psi2d =',        psi2d(debug_ii,debug_jj)
         print *, '       detapsi2d =',    detapsi2d(debug_ii,debug_jj)
         print *, '         dqpsi2d =',      dqpsi2d(debug_ii,debug_jj)
         print *, '    detaetapsi2d =', detaetapsi2d(debug_ii,debug_jj)
         print *, '      detaqpsi2d =',   detaqpsi2d(debug_ii,debug_jj)
         print *, '        dqqpsi2d =',     dqqpsi2d(debug_ii,debug_jj)
      endif

c
c write conformal factor psi on 2D grid to output file if requested
c
      if (output_psi2D .ne. 0) then
         write (message_buffer, '(A,A,A)')
     $         'writing 2D psi to "',
     $            output_psi2D_file_name_fstring(1:fstring_length),
     $         '"'
         call CCTK_INFO(message_buffer)

         call CCTK_FortranString(fstring_length,
     $                           output_psi2D_file_name,
     $                           output_psi2D_file_name_fstring)
         open (9, iostat=io_status, status='replace',
     $         file=output_psi2D_file_name_fstring)
         if (io_status .ne. 0) then 
            write (message_buffer, '(A,A,A,I8)')
     $            'error opening psi2D output file "',
     $            output_psi2D_file_name_fstring(1:fstring_length),
     $            '": io_status=', io_status
            call CCTK_WARN(CCTK_WARN_ABORT, message_buffer)
         endif

         write (9, '(a)')
     $         '# eta          theta (=q)     psi (2D)            psi (3D)'
            do i = 1,neb
            exp_mhalf_eta = exp(-0.5d0 * etagrd(i))
               do j = 1,nqb
               psi3d = psi2d(i,j) * exp_mhalf_eta
               write (9, '(f12.8,a, f12.8,a, g20.10e3,a, g20.10e3)')
     $               etagrd(i), ' ', qgrd(j), ' ',
     $               psi2d(i,j), ' ', psi3d
               end do
            write (9, '(a)') ''
            end do

         close (9, iostat=io_status)
         if (io_status .ne. 0) then 
            write(message_buffer, '(A,I8)')
     $         'error closing psi2D output file: io_status=', io_status
            call CCTK_WARN(CCTK_WARN_ABORT, message_buffer)
         endif
      endif



c
c ***** interpolate psi and its derivatives to the xyz grid positions *****
c ***** and compute the ADM variables there *****
c
c More precisely, at this point we have q, psi, and the psi derivatives
c on the (eta,theta) grid.  We want to interpolate these values to the
c (eta,theta) locations of each of the (x,y,z) grid points.
c
c The (eta,theta) grid only spans the range eta >= 0, so we actually
c interpolate using the (x,y,z) grid points |eta| values, and fix
c things up afterwords.
c

      call CCTK_INFO("interpolating solution to xyz grid points")

      eta = log (r + eps)
      abseta = abs (eta)
      sign_eta = sign (one, eta)
      q = atan2 (sqrt ((x + eps)**2 + y**2), z)
      phi = atan2 (y, x + eps)

      if (debug .ge. 6) then
c posn = (0-origin) 1-D position of this point in interpolator arrays
c        (this is useful because interpolator error messages refer to it)
	 posn = (debug_i-1) + nx*(debug_j-1) + nx*ny*(debug_k-1)
	 print *, '### 3-D interpolation coordinates and inputs ###'
	 print *, '3-D grid size: n[xyz] =', nx,ny,nz
	 print *, 'debug_[ijk] =', debug_i,debug_j,debug_k, '==> posn =', posn
         print *, 'at this 3-D grid point, ...'
	 print *, '        x =',      x(debug_i,debug_j,debug_k)
	 print *, '        y =',      y(debug_i,debug_j,debug_k)
	 print *, '        z =',      z(debug_i,debug_j,debug_k)
	 print *, '      eta =',    eta(debug_i,debug_j,debug_k)
	 print *, '   abseta =', abseta(debug_i,debug_j,debug_k)
	 print *, 'theta [q] =',      q(debug_i,debug_j,debug_k)
	 print *, '      phi =',    phi(debug_i,debug_j,debug_k)
      endif

c set up the interpolator array pointers
      npoints = nx*ny*nz

      coord_origin(1) = etagrd(1)
      coord_origin(2) =   qgrd(1)
      coord_delta(1)  = etagrd(2) - etagrd(1)
      coord_delta(2)  =   qgrd(2) -   qgrd(1)

      if (debug .ge. 6) then
         print *, '### 2-D grid origin:   eta=', coord_origin(1)
         print *, '                     theta=', coord_origin(2)
         print *, '              delta:   eta=', coord_delta(1)
         print *, '                     theta=', coord_delta(2)
      end if

      interp_coords(1) = CCTK_PointerTo(abseta)
      interp_coords(2) = CCTK_PointerTo(q)

      in_array_dims(1) = neb
      in_array_dims(2) = nqb

      in_arrays(1) = CCTK_PointerTo(       psi2d)
      in_arrays(2) = CCTK_PointerTo(   detapsi2d)
      in_arrays(3) = CCTK_PointerTo(     dqpsi2d)
      in_arrays(4) = CCTK_PointerTo(detaetapsi2d)
      in_arrays(5) = CCTK_PointerTo(  detaqpsi2d)
      in_arrays(6) = CCTK_PointerTo(    dqqpsi2d)

      out_arrays(1) = CCTK_PointerTo(       psi2dv)
      out_arrays(2) = CCTK_PointerTo(   detapsi2dv)
      out_arrays(3) = CCTK_PointerTo(     dqpsi2dv)
      out_arrays(4) = CCTK_PointerTo(detaetapsi2dv)
      out_arrays(5) = CCTK_PointerTo(  detaqpsi2dv)
      out_arrays(6) = CCTK_PointerTo(    dqqpsi2dv)

             psi2dv = 1
         detapsi2dv = 0
           dqpsi2dv = 0
      detaetapsi2dv = 0
        detaqpsi2dv = 0
          dqqpsi2dv = 0

      call CCTK_InterpLocalUniform (ierror, 2,
     $                              interp_handle, param_table_handle,
     $                              coord_origin, coord_delta,
     $                              npoints, int(type_codes(1)), interp_coords,
     $                              6, in_array_dims, type_codes, in_arrays,
     $                              6, type_codes, out_arrays)
      if (ierror < 0) then
        write(message_buffer, '(A,I8)')
     $      'error in interpolator: ierror=', ierror
        call CCTK_WARN(CCTK_WARN_ALERT, message_buffer)
      endif

      call Util_TableDestroy (ierror, param_table_handle)

      if (debug .ge. 6) then
         print *, '### interpolation results (at this 3-D grid point) ###'
	 print *, '   psi2dv =', psi2dv(debug_i,debug_j,debug_k)
      end if
c
c ***** compute the ADMBase conformal factor, its derivatives, *****
c ***** metric, and extrinsic curvature from the interpolation output *****
c
      psi = psi2dv * exp (-0.5d0 * eta)
      detapsi2dv = sign_eta * detapsi2dv
      detaqpsi2dv = sign_eta * detaqpsi2dv

      do k=1,nz
         do j=1,ny
            do i=1,nx
c     psix = \partial psi / \partial x / psi
#include "EinsteinInitialData/IDAxiBrillBH/src/psi_1st_deriv.x"

c     psixx = \partial^2\psi / \partial x^2 / psi
#include "EinsteinInitialData/IDAxiBrillBH/src/psi_2nd_deriv.x"
            enddo
         enddo
      enddo

      do k=1,nz
         do j=1,ny
            do i=1,nx
c     Conformal metric
c       gxx = ...
c     Derivatives of the metric (currently commented-out)
c       dxgxx = 1/2 \partial gxx / \partial x
#include "EinsteinInitialData/IDAxiBrillBH/src/gij.x"

               if (r(i,j,k) < 1.0d-10) then
                  
                  psi(i,j,k) = 1
                  
                  psix(i,j,k) = 0
                  psiy(i,j,k) = 0
                  psiz(i,j,k) = 0
                  
                  psixx(i,j,k) = 0
                  psixy(i,j,k) = 0
                  psixz(i,j,k) = 0
                  psiyy(i,j,k) = 0
                  psiyz(i,j,k) = 0
                  psizz(i,j,k) = 0
                  
                  gxx(i,j,k) = 1
                  gxy(i,j,k) = 0
                  gxz(i,j,k) = 0
                  gyy(i,j,k) = 1
                  gyz(i,j,k) = 0
                  gzz(i,j,k) = 1
                  
               end if

            enddo
         enddo
      enddo

c convert to physical metric if StaticConformal is not wanted
      if (generate_StaticConformal_metric .eq. 0) then
         call CCTK_INFO("converting to physical metric")
         call ConfToPhysInPlace(nx, ny, nz,
     $				psi,
     $				gxx, gxy, gxz,
     $				     gyy, gyz,
     $				          gzz)
c        record that we now have a physical metric
         conformal_state = 0
      else
c        record that we computed psi and its 1st and 2nd derivatives
         conformal_state = 3
      end if

c Extrinsic Curvature is identically zero
      kxx = 0.0d0
      kxy = 0.0d0
      kxz = 0.0d0
      kyy = 0.0d0
      kyz = 0.0d0
      kzz = 0.0d0

      if (debug .ge. 6) then
         print *, '### final results (again at this 3-D grid point) ###'
         if (conformal_state .gt. 0) then
            print *, '### ... conformal metric with'
	    print *, '   psi =', psi(debug_i,debug_j,debug_k)
         else
            print *, '### ... physical metric with'
         end if
	 print *, '   gxx =', gxx(debug_i,debug_j,debug_k)
	 print *, '   gxy =', gxy(debug_i,debug_j,debug_k)
	 print *, '   gxz =', gxz(debug_i,debug_j,debug_k)
	 print *, '   gyy =', gyy(debug_i,debug_j,debug_k)
	 print *, '   gyz =', gyz(debug_i,debug_j,debug_k)
	 print *, '   gzz =', gzz(debug_i,debug_j,debug_k)
      endif

c
c ***** diagnostics and final cleanup
c

c ADM mass
      call CCTK_INFO("computing ADM mass")
      i = neb-15
      adm = 0.0d0
      do j=2,nqb-1
        adm = adm
     $        + (psi2d(i,j)-(psi2d(i+1,j)-psi2d(i-1,j))/deta)
     $          *exp(0.5d0*etagrd(i))
      enddo
      adm=adm/(nqb-2)
      print *,'ADM mass: ',adm

      if (CCTK_EQUALS(initial_lapse,"schwarz")) then
         write (*,*)"Initial with schwarzschild-like lapse"
         write (*,*)"using alp = (2r - adm)/(2r+adm)"
         alp = (2.0d0*r - adm)/(2.0d0*r+adm)
      endif

      deallocate(cc,ce,cw,cn,cs,rhs,psi2d,detapsi2d,dqpsi2d,
     $     detaetapsi2d,detaqpsi2d,dqqpsi2d,
     $     etagrd,qgrd,
     $     eta,abseta,sign_eta,q,phi,psi2dv,detapsi2dv,dqpsi2dv,
     $     detaetapsi2dv,detaqpsi2dv,dqqpsi2dv)

      return
      end

```

psi_2nd_deriv.x:
```
        o1 = 5.0000000000000d-1*eta(i,j,k)
        o2 = exp(o1)
        o3 = psi2dv(i,j,k)
        o4 = 1/o3
        o5 = cos(phi(i,j,k))
        o6 = o5**2
        o7 = cos(q(i,j,k))
        o8 = o7**2
        o9 = detapsi2dv(i,j,k)
        o10 = -2.50000000000000d0*eta(i,j,k)
        o11 = exp(o10)
        o12 = dqqpsi2dv(i,j,k)
        o13 = sin(phi(i,j,k))
        o14 = o13**2
        o15 = detaqpsi2dv(i,j,k)
        o16 = sin(q(i,j,k))
        o17 = dqpsi2dv(i,j,k)
        o18 = detaetapsi2dv(i,j,k)
        o19 = o16**2
        o20 = tan(q(i,j,k))
        o21 = 1/o20
        psixx(i,j,k) = o2*o4*(1.00000000000000d0*o11*o14*o17*o21 - 5.000
     &  0000000000d-1*o11*o14*o3 + o11*o18*o19*o6 + 7.5000000000000d-1*o
     &  11*o19*o3*o6 + 2.00000000000000d0*o11*o15*o16*o6*o7 - 3.00000000
     &  000000d0*o11*o16*o17*o6*o7 + o11*o12*o6*o8 - 5.0000000000000d-1*
     &  o11*o3*o6*o8 + o11*o14*o9 - 2.00000000000000d0*o11*o19*o6*o9 + o
     &  11*o6*o8*o9)
        psixy(i,j,k) = o2*o4*(o11*o13*o18*o19*o5 - o11*o13*o17*o21*o5 + 
     &  5.0000000000000d-1*o11*o13*o3*o5 + 7.5000000000000d-1*o11*o13*o1
     &  9*o3*o5 + 2.00000000000000d0*o11*o13*o15*o16*o5*o7 - 3.000000000
     &  00000d0*o11*o13*o16*o17*o5*o7 + o11*o12*o13*o5*o8 - 5.0000000000
     &  000d-1*o11*o13*o3*o5*o8 - o11*o13*o5*o9 - 2.00000000000000d0*o11
     &  *o13*o19*o5*o9 + o11*o13*o5*o8*o9)
        psixz(i,j,k) = o2*o4*(-(o11*o15*o19*o5) + 1.50000000000000d0*o11
     &  *o17*o19*o5 - o11*o12*o16*o5*o7 + o11*o16*o18*o5*o7 + 1.25000000
     &  000000d0*o11*o16*o3*o5*o7 + o11*o15*o5*o8 - 1.50000000000000d0*o
     &  11*o17*o5*o8 - 3.00000000000000d0*o11*o16*o5*o7*o9)
        psiyy(i,j,k) = o2*o4*(o11*o14*o18*o19 + 7.5000000000000d-1*o11*o
     &  14*o19*o3 + 1.00000000000000d0*o11*o17*o21*o6 - 5.0000000000000d
     &  -1*o11*o3*o6 + 2.00000000000000d0*o11*o14*o15*o16*o7 - 3.0000000
     &  0000000d0*o11*o14*o16*o17*o7 + o11*o12*o14*o8 - 5.0000000000000d
     &  -1*o11*o14*o3*o8 - 2.00000000000000d0*o11*o14*o19*o9 + o11*o6*o9
     &   + o11*o14*o8*o9)
        psiyz(i,j,k) = o2*o4*(-(o11*o13*o15*o19) + 1.50000000000000d0*o1
     &  1*o13*o17*o19 - o11*o12*o13*o16*o7 + o11*o13*o16*o18*o7 + 1.2500
     &  0000000000d0*o11*o13*o16*o3*o7 + o11*o13*o15*o8 - 1.500000000000
     &  00d0*o11*o13*o17*o8 - 3.00000000000000d0*o11*o13*o16*o7*o9)
        psizz(i,j,k) = o2*o4*(o11*o12*o19 - 5.0000000000000d-1*o11*o19*o
     &  3 - 2.00000000000000d0*o11*o15*o16*o7 + 3.00000000000000d0*o11*o
     &  16*o17*o7 + o11*o18*o8 + 7.5000000000000d-1*o11*o3*o8 + o11*o19*
     &  o9 - 2.00000000000000d0*o11*o8*o9)

```

gij.x:
```
        o1 = 2.00000000000000d0*phi(i,j,k)
        o2 = cos(o1)
        o3 = -eta0
        o4 = eta(i,j,k) + o3
        o5 = o4**2
        o6 = sigma**2
        o7 = 1/o6
        o8 = -(o5*o7)
        o9 = exp(o8)
        o10 = eta(i,j,k) + eta0
        o11 = o10**2
        o12 = -(o11*o7)
        o13 = exp(o12)
        o14 = o13 + o9
        o15 = sin(q(i,j,k))
        o16 = o15**n
        o17 = 2.00000000000000d0*amp*o14*o16
        o18 = exp(o17)
        o19 = -1.00000000000000d0 + o18
        o20 = eta(i,j,k)**2
        o21 = 2.00000000000000d0*o20
        o22 = eta0**2
        o23 = 2.00000000000000d0*o22
        o24 = eta(i,j,k)*o6
        o25 = o21 + o23 + o24
        o26 = -(o25*o7)
        o27 = exp(o26)
        o28 = 1/o15
        o29 = o20 + o22
        o30 = 2.00000000000000d0*o29*o7
        o31 = exp(o30)
        o32 = sin(phi(i,j,k))
        o33 = sin(o1)
        o34 = o11*o7
        o35 = exp(o34)
        o36 = cos(phi(i,j,k))
        o37 = o32**2
        o38 = cos(q(i,j,k))
        o39 = o38**2
        o40 = o5*o7
        o41 = exp(o40)
        o42 = o15**2
        o43 = o36**2
        o44 = -2.00000000000000d0*o19*o31*o6
        o45 = -2.00000000000000d0*eta(i,j,k)
        o46 = -2.00000000000000d0*eta0
        o47 = n*o6
        o48 = 4.0000000000000d0*eta(i,j,k)*eta0*o7
        o49 = exp(o48)
        o50 = -2.00000000000000d0*eta(i,j,k)*o49
        o51 = 2.00000000000000d0*eta0*o49
        o52 = n*o49*o6
        o53 = 2.00000000000000d0*q(i,j,k)
        o54 = cos(o53)
        o55 = 2.00000000000000d0*eta(i,j,k)
        o56 = 2.00000000000000d0*eta0
        o57 = 2.00000000000000d0*eta(i,j,k)*o49
        o58 = -2.00000000000000d0*eta0*o49
        o59 = o47 + o52 + o55 + o56 + o57 + o58
        o60 = o54*o59
        o61 = o45 + o46 + o47 + o50 + o51 + o52 + o60
        o62 = o17 + o40
        o63 = exp(o62)
        o64 = amp*o16*o61*o63
        o65 = o44 + o64
        o66 = -1.00000000000000d0 + o49
        o67 = -2.00000000000000d0*eta0*o66
        o68 = 1.00000000000000d0 + o49
        o69 = 2.00000000000000d0*eta(i,j,k)*o68
        o70 = n*o6*o68
        o71 = o67 + o69 + o70
        o72 = o56 + o6
        o73 = eta(i,j,k)*o72
        o74 = o20 + o22 + o73
        o75 = -(o7*o74)
        o76 = o17 + o75
        o77 = exp(o76)
        o78 = -eta(i,j,k)
        o79 = exp(o78)
        o80 = -2.00000000000000d0*o29*o7
        o81 = o17 + o80
        o82 = exp(o81)
        o83 = -1.00000000000000d0 + n
        o84 = o15**o83
        o85 = o35 + o41
        o86 = -(n*o39*o6*o85)
        o87 = eta(i,j,k)*o49
        o88 = -(eta0*o49)
        o89 = eta(i,j,k) + eta0 + o87 + o88
        o90 = 2.00000000000000d0*o41*o42*o89
        o91 = o86 + o90
        o92 = o17 + o26
        o93 = exp(o92)
        o94 = n*o39*o6*o85
        o95 = -2.00000000000000d0*o41*o42*o89
        o96 = o94 + o95
        gxx(i,j,k) = 5.0000000000000d-1*(1.00000000000000d0 + o18 + o19*
     &  o2)
c        dxgxx(i,j,k) = 5.0000000000000d-1*o27*o28*o7*(o36*(-2.0000000000
c     &  0000d0*o31*o37*o6 - amp*o16*o18*(2.00000000000000d0*eta(i,j,k)*o35*o42 
c     &  - 3.00000000000000d0*eta0*o35*o42 + 2.00000000000000d0*eta(i,j,k)*o2*o3
c     &  5*o42 + 2.00000000000000d0*eta(i,j,k)*o41*o42 + 2.00000000000000d0*eta0
c     &  *o41*o42 + 2.00000000000000d0*eta(i,j,k)*o2*o41*o42 + 2.00000000000000d
c     &  0*eta0*o2*o41*o42 - n*o35*o39*o6 - n*o2*o35*o39*o6 - n*o39*o41*o
c     &  6 - n*o2*o39*o41*o6)) + o18*(o31*o32*o33*o6 + amp*eta0*o15**(2.0
c     &  0000000000000d0 + n)*o35*cos(3.00000000000000d0*phi(i,j,k))))
c        dygxx(i,j,k) = 5.0000000000000d-1*o27*o28*o32*o43*o65*o7
c        dzgxx(i,j,k) = -(amp*o16*o38*o43*o7*o71*o77)
        gxy(i,j,k) = 5.0000000000000d-1*o19*o33
c        dxgxy(i,j,k) = 5.0000000000000d-1*o7*o79*(-(o19*o2*o28*o32*o6) -
c     &   amp*o33*o36*o82*o84*o91)
c        dygxy(i,j,k) = 5.0000000000000d-1*o7*o79*(1.00000000000000d0*o19
c     &  *o2*o28*o36*o6 - amp*o32*o33*o82*o84*o91)
c        dzgxy(i,j,k) = -5.0000000000000d-1*amp*o16*o33*o38*o7*o71*o77
        gxz(i,j,k) = 0
c        dxgxz(i,j,k) = 0
c        dygxz(i,j,k) = 0
c        dzgxz(i,j,k) = 0
        gyy(i,j,k) = 5.0000000000000d-1*(1.00000000000000d0 + o18 - o19*
     &  o2)
c        dxgyy(i,j,k) = 5.0000000000000d-1*o27*o28*o36*o37*o65*o7
c        dygyy(i,j,k) = 5.0000000000000d-1*o27*o28*o7*(-2.00000000000000d
c     &  0*o31*o32*o43*o6 - 2.00000000000000d0*amp*o16*o18*o32*o37*o91 + 
c     &  o33*o36*o6*exp(2.00000000000000d0*(amp*o14*o16 + o29*o7)))
c        dzgyy(i,j,k) = -(amp*o16*o37*o38*o7*o71*o77)
        gyz(i,j,k) = 0
c        dxgyz(i,j,k) = 0
c        dygyz(i,j,k) = 0
c        dzgyz(i,j,k) = 0
        gzz(i,j,k) = o18
c        dxgzz(i,j,k) = amp*o36*o7*o84*o93*o96
c        dygzz(i,j,k) = amp*o32*o7*o84*o93*o96
c        dzgzz(i,j,k) = -(amp*o16*o38*o7*o71*o77)

```

mg59p.F:
```
#include "cctk.h"
c----------------------------------------------------------------------
      subroutine mgparm(m,ifd59,id5,id9,idi,idg,imx,jmx)
      implicit CCTK_REAL (a-h,o-z)
c----------------------------------------------------------------------
c  Given imx, jmx and ifd59 (See comments in mgsu2), mgparm calculates
c  the number of grids that will be needed, and the dimensions
*  needed for the coefficient, right hand side and solution arrays
*  to store values on all grid levels.
c .....................................................................
*
****  Parameters
*
*  INTEGERS:
*     m :
*         This is the number of grid levels that the multigrid
*         routine will use.
*
*     ifmg :
*          ifmg = 0 - The full multigrid algorithm is not used to
*                     obtain a good initial guess on the fine grid.
*                     (use this if you can provide a good initial guess)
*          ifmg = 1 - The full multigrid algorithm is used to obtain a
*                     good initial guess on the fine grid.
*
*     id5 :
*          Dimension of the arrays ac,aw,as,ae,an,q and f. id5 is the
*          total number of grid points on the finest grid and all
*          coarser grids.
*
*     id9 :
*          Dimension of the arrays asw,ase,ane,anw. If ifd59=5 then
*          id9=idi.  If ifd59=9 then id9=id5.
*          (NOTE: This routine specifically written for 9-point)
*
*     idi :
*          Dimension of the work arrays pu and pd. idi is the total
*          number of grid points on all of the coarser grids.
*
*     idg :
*          Dimension of the work array gam. It is set to the value im,
*          the number of grid points in the i-direction on the finest
*          grid.
*
*     imx,jmx :
*          These are the number of points in the i and j directions
*          including the two ficticious points.
*
      parameter(n5=1,n9=2,ni=3,jm=4,i9=5,j9=6,ifd=7,jred=8)
      dimension np2(20,8)
      iq5=1
      iq9=1
      iqi=1
      m=1
      np2(m,1)=jmx
      np2(m,2)=3
   10 if(np2(m,1).le.3) go to 20
      m=m+1
      np2(m,1)=np2(m-1,1)/2+1
      if(np2(m-1,2).eq.2.and.mod(np2(m-1,1),2).eq.1)
     + np2(m,1)=np2(m,1)+1
      np2(m,2)=2
      go to 10
   20 do 30 k=1,m
      np2(m-k+1,jm)=np2(k,1)
   30 np2(m-k+1,jred)=np2(k,2)
      do 40 k=m,1,-1
      ktot=imx*np2(k,jm)
      np2(k,n5)=iq5
      iq5=iq5+ktot
      np2(k,n9)=iq9
      if(k.lt.m.or.ifd59.eq.9) iq9=iq9+ktot
      np2(k,ni)=iqi
   40 if(k.lt.m) iqi=iqi+ktot
      do 50 k=1,m
      np2(k,i9)=imx
      np2(k,j9)=np2(k,jm)
   50 np2(k,ifd)=9
         if(ifd59.eq.5) then
      np2(m,i9)=1
      np2(m,j9)=1
      np2(m,ifd)=5
         endif
      id5=iq5-1
      id9=iq9-1
      idi=iqi-1
      idg=imx
      return
      end
*
*
*
************************************************************************
*
      subroutine mg9 (idim,ilower,iupper,jdim,jlower,jupper,
     &             cc,cn,cs,cw,ce,cnw,cne,csw,cse,u,rhs,
     &             id5,id9,idi,idg,ifmg,eps,rmax,ier)
      implicit CCTK_REAL (a-h,o-z)
*
************************************************************************
*
*
*     This routine is a wrapper for the multigrid solver.  The input
*  arrays are the finite difference coefficients on the 2D grid with
*  the boundary conditions absorbed into them.
*
****  Parameters
*
*  INTEGERS:
*     idim,jdim :
*          These define sizes of the coefficient arrays passed to this
*          routine.
*
*     ilower,iupper,
*     jlower,jupper :
*          These are the indices of the computational grid that
*          correspond to upper and lower index limits for points on
*          which computations are actually done.
*
*     id5 :
*          Dimension of the arrays ac,aw,as,ae,an,q and f. id5 is the
*          total number of grid points on the finest grid and all
*          coarser grids.
*
*     id9 :
*          Dimension of the arrays asw,ase,ane,anw. If ifd59=5 then
*          id9=idi.  If ifd59=9 then id9=id5.
*          (NOTE: This routine specifically written for 9-point)
*
*     idi :
*          Dimension of the work arrays pu and pd. idi is the total
*          number of grid points on all of the coarser grids.
*
*     idg :
*          Dimension of the work array gam. It is set to the value im,
*          the number of grid points in the i-direction on the finest
*          grid.
*
*     ifmg :
*          ifmg = 0 - The full multigrid algorithm is not used to
*                     obtain a good initial guess on the fine grid.
*                     (use this if you can provide a good initial guess)
*          ifmg = 1 - The full multigrid algorithm is used to obtain a
*                     good initial guess on the fine grid.
*
*     ier :
*          This is an error flag with the following possible return
*          values:
*              ier =  0 => solver converged without error
*              ier = -1 => solver did not converge
*
*  REALS:
*     cc(idim,jdim),cn(idim,jdim),
*     cs(idim,jdim),cw(idim,jdim),ce(idim,jdim),
*     cnw(idim,jdim),cne(idim,jdim),
*     csw(idim,jdim),cse(idim,jdim) :
*          These are the finite difference coefficient arrays for a
*          nine-point stencil on the two dimensional grid as follows:
*
*
*               cnw    cn    cne
*            ^
*            |  cw     cc    ce
* increasing |
*  j values  |  csw    cs    cse
*   (theta)  |
*             --------> increasing i values (eta)
*
*  Ie. the coresspondence is : nw : i-1,j+1
*                              n  : i,j+1
*                              ne : i+1,j+1
*                              w  : i-1,j
*                              c  : i,j
*                              e  : i+1,j
*                              sw : i-1,j-1
*                              s  : i,j-1
*                              se : i+1,j-1
*
*     u :
*          Input: this contains the initial guess to the solution of the
*                 equation
*          Output: This contains the final approximation to the solution
*                 determined by the multigrid solver.
*     
*     rhs :
*          This array contains the values of the right hand side of the
*          equation at every point on the rwo dimensional grid.
*
*     eps :
*          eps > 0.  The maximum norm of the residual is calculated at
*                    the end of each multigrid cycle. The algorithm is
*                    terminated when this maximum becomes less than eps
*                    or when the maximum number of iterations (see ncyc)
*                    is exceeded.  It is up to the user to provide a
*                    meaningfull tolerance criteria for the particular
*                    problem being solved.
*
*     rmax:
*          This is the final value of the residual calcu;ated.
*
************************************************************************
*
*

      integer idim,ilower,iupper,jdim,jlower,jupper,ifmg
      integer id5,id9,idi,idg,ier
      CCTK_REAL cc(idim,jdim),cn(idim,jdim),cs(idim,jdim),cw(idim,jdim),
     &     ce(idim,jdim),cnw(idim,jdim),cne(idim,jdim),csw(idim,jdim),
     &     cse(idim,jdim),u(idim,jdim),rhs(idim,jdim)
      CCTK_REAL eps,rmax

*
************************************************************************
*
*  Variable definitions:
*
*  Integers:
*     ifd59 :
*          ifd59 = 5 - means a 5-point finite difference stencil
*                      (ac,an,as,aw,ae) is defined on the finest grid.
*          ifd59 = 9 - means a 9-point finite difference stencil
*                      (ac,an,as,aw,ae,anw,ane,asw,ase) is defined on
*                      the finest grid by the user.
*                      (NOTE: This routine specifically written
*                             for 9-point)
*
*     ncyc :
*          The maximum number of multigrid "v"-cycles to be used. If
*          the maximum norm of the residual is not less than tol at the
*          end of ncyc cycles, the algorithm is terminated.
*          (NOTE: ncyc <= 40 )
*          
*     np(20,8) :
*          Input: When the iskip=1,-1 or -2 option is used, np2 is
*                 assumed to contain the grid information for umgs2.
*          Output: When the iskip=0 option is used, the grid
*                 information for umgs2 is returned in np2.
*          (NOTE: This is only useful for multiple instance problems)
*
*     iskip :
*          iskip = 0 - The coarse grid information, coarse grid
*                      operators and interpolation coefficients are
*                      calculated by umgs2.  This information is stored
*                      in the arrays ac, aw, as, asw, ase, pu, pd, np2
*                      and the variable.
*          iskip = 1 - The calculation of the coarse grid information,
*                      coarse grid operators and interpolation
*                      coefficients is skipped.  This option would be
*                      used when umgs2 has been called with iskip=0 and
*                      is being called again to solve a system of
*                      equations with the same matrix. This would be
*                      the case in, say, parabolic problems with time
*                      independent coefficients.
*          iskip =-1 - The set up of pointers (ugrdfn) is skipped.
*                      Coarse grid operators and interpolation
*                      coefficients are calculated and the given matrix
*                      equation is solved.  This option would be used
*                      when umgs2 has been called with iskip=0 and is
*                      being called again to solve a system of equations
*                      with a different matrix of the same dimensions.
*                      This would be the case for, say, parabolic
*                      problems with time dependent coefficients.
*          iskip =-2 - The set up of pointers (ugrdfn) is skipped.
*                      Coarse grid operators and interpolation
*                      coefficients are calculated and returned.
*                      No matrix solve.
*
*     ipc :
*          ipc = 0 or 1.
*          ipc is a multigrid parameter which determines the type of
*          interpolation to be used.  Usually ipc=1 is best.  However,
*          if the boundary condition equations have been absorbed into
*          the interior equations then ipc=0 can be used which results
*          in a slightly more efficient algorithm.
*
*     nman :
*          nman = 0 usually.
*          nman = 1 signals that the fine grid equations are singulari
*          for the case when homogeneous Neumann boundary conditions are
*          applied along the entire boundary.  In this case, the
*          difference equations are singular and the condition that the
*          integral of q over the domain be zero is added to the set of
*          difference equations.  This condition is satisfied by adding
*          the appropriate constant vector to q on the fine grid.  It is
*          assumed, in this case, that a well-defined problem has been
*          given to mgss2, i.e. the integral of f over the domain is
*          zero.
*
*     im :
*          The number of grid points in the x-direction (including two
*          ficticious points)
*     jm :
*          The number of grid points in the y-direction (including two
*          ficticious points)
*
*     linp :
*          This is a dummy argument left over from the authors
*          development of the code
*             Use:  common /io/ linp,lout
*
*     lout :
*          lout = unit number of output file into which the maximum norm
*          of the residual after each multigrid v-cycle" is printed.
*             Use:  common /io/ linp,lout
*
*     iscale :
*          Flag to indicate whether problem can be diagonally scaled to
*          speed convergence of the multigrid solver.
*
*     REALS:
*
*     ac(id5),an(id5),as(id5),aw(id5),ae(id5),
*     anw(id9),ane(id9),asw(id9),ase(id9) :
*          Input: ac, an, as, aw, ae, anw, ane, asw and ase contain the
*                 stencil coefficients for the difference operator on
*                 the finest grid. When the iskip=1 option is used,
*                 these arrays also are assumed to contain the coarse
*                 grid difference stencil coeficients.
*          Output: when the iskip=0 option is used, the coarse grid
*                 stencil coeficients are returned in ac, an, as, aw,
*                 ae, anw, ane, asw and ase.
*
*     ru(idi),rd(idi),rc(idi) :
*          Real work arrays.
*
*     pu(idi),pd(idi),pc(idi) :
*          Real work arrays.
*          Input: when the iskip=1 option is used, these arrays are
*                 assumed to contain the interpolation coefficients used
*                 in the semi-coarsening multigrid algorithm.
*          Output: when the iskip=0 option is used, the interpolation
*                 coeficients are returned in pu and pd.
*
*     f(id5) :
*          f contains the right hand side vector of the matrix
*          equation to be solved by umgs2.
*
*     q(id5) :
*          If ifmg=0, q contains the initial guess on the fine grid.
*          If ifmg=1, the initial guess on the fine grid is determined
*                     by the full multigrid process and the value of
*                     q on input to umgs2 not used.
*
*     tol :
*          tol > 0.  The maximum norm of the residual is calculated at
*                    the end of each multigrid cycle. The algorithm is
*                    terminated when this maximum becomes less than tol
*                    or when the maximum number of iterations (see ncyc)
*                    is exceeded.  It is up to the user to provide a
*                    meaningfull tolerance criteria for the particular
*                    problem being solved.
*          tol = 0.  Perform ncyc multigrid cycles.  Calculate and print
*                    the maximum norm of the residual after each cycle.
*          tol =-1.  Perform ncyc multigrid cycles.  The maximum norm of
*                    the final residual is calculated and returned in
*                    the variable rmax in the calling list of umgs2.
*          tol =-2.  Perform ncyc multigrid cycles.  The maximum norm of
*                    the residual is not calculated.
*
*     rmax :
*          If tol.ge.-1., the final residual norm is returned in rmax.
*
************************************************************************
*
*

      integer ncyc,ifd59
      parameter (ncyc=40,ifd59=9)

      integer np2(20,8)
      integer iskip,ipc,nman
      parameter (iskip=0,ipc=1,nman=0)
      integer irc,irurd,im,jm
      integer linp,lout
      common /io/ linp,lout

      CCTK_REAL ac(id5),an(id5),as(id5),aw(id5),ae(id5),
     &     anw(id9),ane(id9),asw(id9),ase(id9),
     &     q(id5),f(id5),gam(idg)

      CCTK_REAL ru(idi),rd(idi),rc(idi),pu(idi),pd(idi),pc(idi)

      CCTK_REAL tol

      integer iscale,itry


      ier=0

*
* Set some parameters for multigrid solver
*
      lout=6
c      rewind(unit=lout)
      irc=0
      irurd=0
      im=iupper-ilower+3
      jm=jupper-jlower+3
      tol=eps

*
*  Set up coefficients into vectors with correct indexing
*
      do 110 j=jlower,jupper
      do 100 i=ilower,iupper
      n=(j+1-jlower)*im + i+1-(ilower-1)
      ac(n)=cc(i,j)
      an(n)=cn(i,j)
      as(n)=cs(i,j)
      aw(n)=cw(i,j)
      ae(n)=ce(i,j)
      anw(n)=cnw(i,j)
      ane(n)=cne(i,j)
      asw(n)=csw(i,j)
      ase(n)=cse(i,j)
      q(n)=u(i,j)
      f(n)=rhs(i,j)
  100 continue
  110 continue


*
*  Determine whether we can diagonal scale the problem to speed
*  convergence. Can only be done if there are no zeros on the main
*  diagonal (ie. central difference coefficient).
*
      iscale=1
      do 200 j=jlower,jupper
      do 205 i=ilower,iupper
      n=(j+1-jlower)*im + i+1-(ilower-1)
      if (ac(n) .eq. 0.) then
        iscale=0
      endif
  205 continue
  200 continue

*
*  Do the diagonal scaling if we can.
*
      if (iscale.eq.1) then

      do 210 j=jlower,jupper
      do 215 i=ilower,iupper
        n=(j+1-jlower)*im + i+1-(ilower-1)
        f(n)=f(n)/ac(n)
        ase(n)=ase(n)/ac(n)
        asw(n)=asw(n)/ac(n)
        ane(n)=ane(n)/ac(n)
        anw(n)=anw(n)/ac(n)
        ae(n)=ae(n)/ac(n)
        aw(n)=aw(n)/ac(n)
        as(n)=as(n)/ac(n)
        an(n)=an(n)/ac(n)
        ac(n)=1.
  215 continue
  210 continue

      endif

c 
c   Now call the multigrid routine

      itry=0
      
 1122 call umgs2(
     . ac,aw,as,ae,an,asw,ase,ane,anw,q,f,pu,pd,pc,ru,rd,rc,gam,np2,
     . ifd59,ifmg,ncyc,tol,nman,im,jm,id5,id9,idi,m,iskip,rmax,
     . ipc,irc,irurd)

      if ((rmax.gt.tol).and.(itry.le.5)) then
        itry=itry+1
        print*,"Retry #",itry
        goto 1122
      endif

      if (rmax.gt.tol) then
        ier = -1
        print*,"Did not converge"
        print*," maximum residual    = ",rmax
        print*," tolerance           = ",tol
      endif

*
*  Convert the solution back to the 2D array form
*
      do 510 j=jlower,jupper
      do 500 i=ilower,iupper
      n=(j+1-jlower)*im + i+1-(ilower-1)
      u(i,j)=q(n)
  500 continue
  510 continue

      return
      end



*
*
*
************************************************************************
*
      subroutine mg5 (idim,ilower,iupper,jdim,jlower,jupper,
     &             cc,cn,cs,cw,ce,u,rhs,
     &             id5,id9,idi,idg,ifmg,eps,rmax,ier)
      implicit CCTK_REAL (a-h,o-z)
*
************************************************************************
*
*
*     This routine is a wrapper for the multigrid solver.  The input
*  arrays are the finite difference coefficients on the 2D grid with
*  the boundary conditions absorbed into them.
*
****  Parameters
*
*  INTEGERS:
*     idim,jdim :
*          These define sizes of the coefficient arrays passed to this
*          routine.
*
*     ilower,iupper,
*     jlower,jupper :
*          These are the indices of the computational grid that
*          correspond to upper and lower index limits for points on
*          which computations are actually done.
*
*     id5 :
*          Dimension of the arrays ac,aw,as,ae,an,q and f. id5 is the
*          total number of grid points on the finest grid and all
*          coarser grids.
*
*     id9 :
*          Dimension of the arrays asw,ase,ane,anw. If ifd59=5 then
*          id9=idi.  If ifd59=9 then id9=id5.
*          (NOTE: This routine specifically written for 5-point)
*
*     idi :
*          Dimension of the work arrays pu and pd. idi is the total
*          number of grid points on all of the coarser grids.
*
*     idg :
*          Dimension of the work array gam. It is set to the value im,
*          the number of grid points in the i-direction on the finest
*          grid.
*
*     ifmg :
*          ifmg = 0 - The full multigrid algorithm is not used to
*                     obtain a good initial guess on the fine grid.
*                     (use this if you can provide a good initial guess)
*          ifmg = 1 - The full multigrid algorithm is used to obtain a
*                     good initial guess on the fine grid.
*
*     ier :
*          This is an error flag with the following possible return
*          values:
*              ier =  0 => solver converged without error
*              ier = -1 => solver did not converge
*
*  REALS:
*     cc(idim,jdim),cn(idim,jdim),
*     cs(idim,jdim),cw(idim,jdim),ce(idim,jdim):
*          These are the finite difference coefficient arrays for a
*          five-point stencil on the two dimensional grid as follows:
*
*
*                      cn       
*            ^
*            |  cw     cc    ce
* increasing |
*  j values  |         cs       
*   (theta)  |
*             --------> increasing i values (eta)
*
*  Ie. the coresspondence is : n  : i,j+1
*                              ne : i+1,j+1
*                              c  : i,j
*                              e  : i+1,j
*                              s  : i,j-1
*
*     u :
*          Input: this contains the initial guess to the solution of the
*                 equation
*          Output: This contains the final approximation to the solution
*                 determined by the multigrid solver.
*     
*     rhs :
*          This array contains the values of the right hand side of the
*          equation at every point on the rwo dimensional grid.
*
*     eps :
*          eps > 0.  The maximum norm of the residual is calculated at
*                    the end of each multigrid cycle. The algorithm is
*                    terminated when this maximum becomes less than tol
*                    or when the maximum number of iterations (see ncyc)
*                    is exceeded.  It is up to the user to provide a
*                    meaningfull tolerance criteria for the particular
*                    problem being solved.
*     rmax:
*          This is the final value of the residual calcu;ated.
*
************************************************************************
*
*

      integer idim,ilower,iupper,jdim,jlower,jupper,ifmg
      integer id5,id9,idi,idg,ier
      CCTK_REAL cc(idim,jdim),cn(idim,jdim),cs(idim,jdim),cw(idim,jdim),
     &     ce(idim,jdim),u(idim,jdim),rhs(idim,jdim)
      CCTK_REAL eps,rmax

*
************************************************************************
*
*  Variable definitions:
*
*  Integers:
*     ifd59 :
*          ifd59 = 5 - means a 5-point finite difference stencil
*                      (ac,an,as,aw,ae) is defined on the finest grid.
*          ifd59 = 9 - means a 9-point finite difference stencil
*                      (ac,an,as,aw,ae,anw,ane,asw,ase) is defined on
*                      the finest grid by the user.
*                      (NOTE: This routine specifically written
*                             for 5-point)
*
*     ncyc :
*          The maximum number of multigrid "v"-cycles to be used. If
*          the maximum norm of the residual is not less than tol at the
*          end of ncyc cycles, the algorithm is terminated.
*          (NOTE: ncyc <= 40 )
*          
*     np(20,8) :
*          Input: When the iskip=1,-1 or -2 option is used, np2 is
*                 assumed to contain the grid information for umgs2.
*          Output: When the iskip=0 option is used, the grid
*                 information for umgs2 is returned in np2.
*          (NOTE: This is only useful for multiple instance problems)
*
*     iskip :
*          iskip = 0 - The coarse grid information, coarse grid
*                      operators and interpolation coefficients are
*                      calculated by umgs2.  This information is stored
*                      in the arrays ac, aw, as, asw, ase, pu, pd, np2
*                      and the variable.
*          iskip = 1 - The calculation of the coarse grid information,
*                      coarse grid operators and interpolation
*                      coefficients is skipped.  This option would be
*                      used when umgs2 has been called with iskip=0 and
*                      is being called again to solve a system of
*                      equations with the same matrix. This would be
*                      the case in, say, parabolic problems with time
*                      independent coefficients.
*          iskip =-1 - The set up of pointers (ugrdfn) is skipped.
*                      Coarse grid operators and interpolation
*                      coefficients are calculated and the given matrix
*                      equation is solved.  This option would be used
*                      when umgs2 has been called with iskip=0 and is
*                      being called again to solve a system of equations
*                      with a different matrix of the same dimensions.
*                      This would be the case for, say, parabolic
*                      problems with time dependent coefficients.
*          iskip =-2 - The set up of pointers (ugrdfn) is skipped.
*                      Coarse grid operators and interpolation
*                      coefficients are calculated and returned.
*                      No matrix solve.
*
*     ipc :
*          ipc = 0 or 1.
*          ipc is a multigrid parameter which determines the type of
*          interpolation to be used.  Usually ipc=1 is best.  However,
*          if the boundary condition equations have been absorbed into
*          the interior equations then ipc=0 can be used which results
*          in a slightly more efficient algorithm.
*
*     nman :
*          nman = 0 usually.
*          nman =1 signals that the fine grid equations are singular for
*          the case when homogeneous Neumann boundary conditions are
*          applied along the entire boundary.  In this case, the
*          difference equations are singular and the condition that the
*          integral of q over the domain be zero is added to the set of
*          difference equations.  This condition is satisfied by adding
*          the appropriate constant vector to q on the fine grid.  It is
*          assumed, in this case, that a well-defined problem has been
*          given to mgss2, i.e. the integral of f over the domain is
*          zero.
*
*     im :
*          The number of grid points in the x-direction (including two
*          ficticious points)
*     jm :
*          The number of grid points in the y-direction (including two
*          ficticious points)
*
*     linp :
*          This is a dummy argument left over from the authors
*          development of the code
*             Use:  common /io/ linp,lout
*
*     lout :
*          lout = unit number of output file into which the maximum norm
*          of the residual after each multigrid v-cycle" is printed.
*             Use:  common /io/ linp,lout
*
*     iscale :
*          Flag to indicate whether problem can be diagonally scaled to
*          speed convergence of the multigrid solver.
*
*     REALS:
*
*     ac(id5),an(id5),as(id5),aw(id5),ae(id5),
*     anw(id9),ane(id9),asw(id9),ase(id9) :
*          Input: ac, an, as, aw, ae, anw, ane, asw and ase contain the
*                 stencil coefficients for the difference operator on
*                 the finest grid. When the iskip=1 option is used,
*                 these arrays also are assumed to contain the coarse
*                 grid difference stencil coeficients.
*          Output: when the iskip=0 option is used, the coarse grid
*                 stencil coeficients are returned in ac, an, as, aw,
*                 ae, anw, ane, asw and ase.
*
*     ru(idi),rd(idi),rc(idi) :
*          Real work arrays.
*
*     pu(idi),pd(idi),pc(idi) :
*          Real work arrays.
*          Input: when the iskip=1 option is used, these arrays are
*                 assumed to contain the interpolation coefficients used
*                 in the semi-coarsening multigrid algorithm.
*          Output: when the iskip=0 option is used, the interpolation
*                 coeficients are returned in pu and pd.
*
*     f(id5) :
*          f contains the right hand side vector of the matrix
*          equation to be solved by umgs2.
*
*     q(id5) :
*          If ifmg=0, q contains the initial guess on the fine grid.
*          If ifmg=1, the initial guess on the fine grid is determined
*                     by the full multigrid process and the value of
*                     q on input to umgs2 not used.
*
*     tol :
*          tol > 0.  The maximum norm of the residual is calculated at
*                    the end of each multigrid cycle. The algorithm is
*                    terminated when this maximum becomes less than tol
*                    or when the maximum number of iterations (see ncyc)
*                    is exceeded.  It is up to the user to provide a
*                    meaningfull tolerance criteria for the particular
*                    problem being solved.
*          tol = 0.  Perform ncyc multigrid cycles.  Calculate and print
*                    the maximum norm of the residual after each cycle.
*          tol =-1.  Perform ncyc multigrid cycles.  The maximum norm of
*                    the final residual is calculated and returned in
*                    the variable rmax in the calling list of umgs2.
*          tol =-2.  Perform ncyc multigrid cycles.  The maximum norm of
*                    the residual is not calculated.
*
************************************************************************
*
*

      integer ncyc,ifd59
      parameter (ncyc=40,ifd59=5)

*     integer id5,id9,idi,idg
*  This is for a 103x28 grid
*     parameter(id5=6695,id9=3811,idi=3811,idg=103)
*  This is for a 203x56 grid
*     parameter(id5=24969,id9=13601,idi=13601,idg=203)
*  This is for a 403x118 grid
*     parameter(id5=100750,id9=52793,idi=52793,idg=403)

      integer np2(20,8)
      integer iskip,ipc,nman
      parameter (iskip=0,ipc=1,nman=0)
      integer irc,irurd,im,jm
      integer linp,lout
      common /io/ linp,lout

      CCTK_REAL ac(id5),an(id5),as(id5),aw(id5),ae(id5),
     &     anw(id9),ane(id9),asw(id9),ase(id9),
     &     q(id5),f(id5),gam(idg)

      CCTK_REAL ru(idi),rd(idi),rc(idi),pu(idi),pd(idi),pc(idi)

      CCTK_REAL tol

      integer iscale,itry



      ier=0
*
* Set some parameters for multigrid solver
*
      lout=6
c      rewind(unit=lout)
      irc=0
      irurd=0
      im=iupper-ilower+3
      jm=jupper-jlower+3
      tol=eps


*
*  Set up coefficients into vectors with correct indexing
*
      do 110 j=jlower,jupper
      do 100 i=ilower,iupper
      n=(j+1-jlower)*im + i+1-(ilower-1)
      ac(n)=cc(i,j)
      an(n)=cn(i,j)
      as(n)=cs(i,j)
      aw(n)=cw(i,j)
      ae(n)=ce(i,j)
      anw(n)=0.
      ane(n)=0.
      asw(n)=0.
      ase(n)=0.
      q(n)=u(i,j)
      f(n)=rhs(i,j)
  100 continue
  110 continue


*
*  Determine whether we can diagonal scale the problem to speed
*  convergence. Can only be done if there are no zeros on the main
*  diagonal (ie. central difference coefficient).
*
      iscale=1
      do 200 j=jlower,jupper
      do 205 i=ilower,iupper
      n=(j+1-jlower)*im + i+1-(ilower-1)
      if (ac(n) .eq. 0.) then
        iscale=0
      endif
  205 continue
  200 continue

*
*  Do the diagonal scaling if we can.
*
      if (iscale.eq.1) then

      do 210 j=jlower,jupper
      do 215 i=ilower,iupper
        n=(j+1-jlower)*im + i+1-(ilower-1)
        f(n)=f(n)/ac(n)
        ae(n)=ae(n)/ac(n)
        aw(n)=aw(n)/ac(n)
        as(n)=as(n)/ac(n)
        an(n)=an(n)/ac(n)
        ac(n)=1.
  215 continue
  210 continue

      endif

c 
c   Now call the multigrid routine

      itry=0
      
 1122 call umgs2(
     + ac,aw,as,ae,an,asw,ase,ane,anw,q,f,pu,pd,pc,ru,rd,rc,gam,np2,
     + ifd59,ifmg,ncyc,tol,nman,im,jm,id5,id9,idi,m,iskip,rmax,
     + ipc,irc,irurd)


      if ((rmax.gt.tol).and.(itry.le.5)) then
        itry=itry+1
        print*,"Retry #",itry
        goto 1122
      endif

      if (rmax.gt.tol) then
        ier = -1
        print*,"Did not converge"
        print*," maximum residual    = ",rmax
        print*," tolerance           = ",tol
      endif

*
*  Convert the solution back to the 2D array form
*
      do 510 j=jlower,jupper
      do 500 i=ilower,iupper
      n=(j+1-jlower)*im + i+1-(ilower-1)
      u(i,j)=q(n)
  500 continue
  510 continue

      return
      end

```

make.code.defn:
```
# Main make.code.defn file for thorn IDAxiBrillBH
# $Header$

# Source files in this directory
SRCS = IDAxiBrillBH.F mg59p.F shmgp.F77 ParamCheck.c

# Subdirectories containing source files
SUBDIRS = 

```

shmgp.F77:
```
#include "cctk.h"
c----------------------------------------------------------------------
      subroutine umgs2(
     + ac,aw,as,ae,an,asw,ase,ane,anw,q,f,pu,pd,pc,ru,rd,rc,gam,np2,
     + ifd59,ifmg,ncyc,tol,nman,im,jm,id5,id9,idi,m,iskip,rmax,
     + ipc,irc,irurd)
      implicit CCTK_REAL(a-h,o-z)
c----------------------------------------------------------------------
cdir$ noinline
c** SUBROUTINE UMGS2
c
c** COPYRIGHT: Ecodynamics Research Associates, Inc.
c
c** Date written: June, 1990
c** Author:  Steve Schaffer
c            Mathematics Department
c            New Mexico Tech
c            Socorro, NM  87801
c            505-835-5811
c
c** DESCRIPTION:
c     umgs2 is a black box symmetric matrix solver.  It is written
c     in unsymmetric storage mode and can be used to solve mildly
c     nonsymmetric problems.  The user provides a matrix and right hand
c     side vector corresponding to a 5 or 9 point finite difference/
c     finite volume discretization of a symmetric second order PDE.
c     umgs2 will construct a sequence of coarse grids and coarse
c     grid operators and then solve the matrix equation using a
c     y-direction semi-coarsening multigrid algorithm and return
c     the solution vector.  If a sequence of matrix problems are
c     to be solved using the same matrix, computational time can
c     be saved by skipping the construction of the coarse grid
c     information in subsequent calls to umgs2. 
c
c     The matrix on the finest grid is stored in the arrays ac,aw,as,
c     an,asw,ase,ane and anw.  The difference stencil at the point
c     (i,j) given by
c
c         nw  n  ne        anw(i,j)   an(i,j)   ane(i,j)
c          w  c  e    =    aw(i,j)    ac(i,j)   aw(i,j)
c         sw  s  se        asw(i,j)   as(i,j)   ase(i,j)
c
c     If the difference stencil on the fine grid is a 5 point stencil
c     then the arrays asw,ase,ane,anw are not used and the
c     stencil is given by
c
c             n                     an(i,j)
c          w  c  e    =    aw(i,j)  ac(i,j)   ae(i,j)
c             s                     as(i,j)
c
c     However, asw,ase,ane,anw still need to be dimensioned (by id9)
c     in the calling program as they are used in the coarse grid
c     calculations.
c
c** STORAGE
c     It is assumed that a set of ficticious points have been defined
c     along the entire boundary.  These points have nothing to do with
c     the solution and are used for programming convenience and
c     vectorization purposes.  Storage is allocated for the stencil
c     elements ac,aw,as,asw,ase, the solution vector, q, and the
c     right hand side vector, f, at these ficticious points.  The
c     stencils at these ficticious points and all stencil connections
c     to them are set to zero in the subroutine useta which is called
c     by umgs2.  The computational grid is depicted by
c
c         x   x   x   x              x   x   x   x
c
c         x   *   *   *              *   *   *   x
c
c         x   *   *   *              *   *   *   x
c    .
c    .
c    .
c         x   *   *   *              *   *   *   x
c
c         x   *   *   *              *   *   *   x
c
c         x   x   x   x              x   x   x   x
c
c     where x depicts the ficticious points and * depicts the interior
c     points.  The total storage requirements for the fine grid problem
c     is then 5*im*jm for 5 point stencils and 7*im*jm for 9 point
c     stencils.  The total storage requirements for the multigrid
c     solution is approximately 2 to 3 times that of the storage
c     requirements of the fine grid problem. (See DIMENSION PARAMETERS).
c     Note:  The first im*jm elements of the arrays ac,aw,as,[asw,ase],
c     q and f correspond to the finest grid.
c
c** DIMENSION PARAMETERS
c     The arrays ac,aw,ae,asw,ase,q,f,pu,pd and pc are dimensioned as one
c     dimensional arrays in the calling program.  They are dimensioned
c     as two dimensional arrays in the working subroutines.  The one
c     dimensional storage of the arrays, say q, follows: n=(j-1)*jm+i,
c     where n is the element location in the one dimensional storage of
c     q corresponding to the (i,j)th element of the two dimensional
c     storage of q and jm is the number of grid points in the j
c     direction (including the two ficticious points).
c
c     The dimension parameters are id5, id9, idi and idg.  They can be
c     determined by running the companion program MSS2DIM.F.
c      id5 - Integer variable.
c            Dimension of the arrays ac,aw,as,ae,an,q and f in the
c            calling program.  id5 is the total number of grid points
c            on the finest grid and all coarser grids.
c      id9 - Integer variable.
c            Dimension of the arrays asw,ase,ane,anw in the calling
c            program.  If ifd59=5 then id9=idi.  If ifd59=9 then
c            id9=id5.
c      idi - Integer variable.
c            Dimension of the work arrays pu and pd in the calling
c            program.  idi is the total number of grid points on all
c            of the coarser grids.
c      idg - Integer variable.
c            Dimension of the work array gam in the calling program.
c            It is set to the value im, the number of grid points
c            in the i-direction on the finest grid.
c
c** INPUT
c            (Note: all variable types are set implicitly)
c ac,aw,as
c    ae,an - Real arrays.  Dimensioned (id5) in calling program.
c            See comments in DESCRIPTION and DIMENSION PARAMETERS.
c  asw,ase
c  ane,anw - Real arrays.  Dimensioned (id9) in calling program.
c            See comments in DESCRIPTION and DIMENSION PARAMETERS.
c        f - Real array.  Dimensioned (id5) in calling program.
c            f contains the right hand side vector of the matrix
c            equation to be solved by umgs2.
c        q - Real array.  Dimensioned (id5) in calling program.
c            If ifmg=0, q contains the initial guess on the fine
c            grid.  If ifmg=1, the initial guess on the fine grid
c            is determined by the full multigrid process and the
c            value of q on input to umgs2 not used.
c   ifd59 -  Integer variable.
c            =5 - means a 5-point finite difference stencil (ac,aw and
c                 as) is defined on the finest grid by the user.
c            =9 - means a 9-point finite difference stencil (ac,aw,as,
c                 asw, ase) is defined on the finest grid by the user.
c    ifmg - Integer variable.
c           =0 - The full multigrid algorithm is not used to obtain a
c                good initial guess on the fine grid.
c           =1 - The full multigrid algorithm is used to obtain a good
c                initial guess on the fine grid.
c    ncyc - Integer variable.
c           The maximum number of multigrid v-cycles to be used.
c           If the maximum norm of the residual is not less than tol
c           at the end of ncyc cycles, the algorithm is terminated.
c     tol - Real variable.
c           >0 - The maximum norm of the residual is calculated at the
c           end of each multigrid cycle.  The algorithm is terminated
c           when this maximum becomes less than tol or when the maximum
c           number of iterations (see ncyc) is exceeded.  It is up to
c           the user to provide a meaningfull tolerance criteria for
c           the particular problem being solved.
c           =0 - Perform ncyc multigrid cycles.  Calculate and print
c           the maximum norm of the residual after each cycle.
c           =-1. - Perform ncyc multigrid cycles.  The maximum norm of
c           the final residual is calculated and returned in the
c           variable rmax in the calling list of umgs2.
c           =-2. - Perform ncyc multigrid cycles.  The maximum norm of
c           the residual is not calculated.
c   iskip - Integer variable.
c           =0 - The coarse grid information, coarse grid operators
c                and interpolation coefficients are calculated by
c                umgs2.  This information is stored in the arrays
c                ac, aw, as, asw, ase, pu, pd, np2 and the variable m
c                and returned to the calling program.
c           =1 - The calculation of the coarse grid information, coarse
c                grid operators and interpolation coefficients is
c                skipped.  This option would be used when umgs2 has
c                been called with iskip=0 and is being called again
c                to solve a system of equations with the same matrix.
c                This would be the case in, say, parabolic problems
c                with time independent coefficients.
c           =-1 -The set up of pointers (ugrdfn) is skipped.  Coarse grid
c                operators and interpolation coefficients are calculated
c                and the given matrix equation is solved.  This option
c                would be used when umgs2 has been called with iskip=0
c                and is being called again to solve a system of
c                equations with a different matrix of the same
c                dimensions.  This would be the case for, say,
c                parabolic problems with time dependent coefficients.
c           =-2 -The set up of pointers (ugrdfn) is skipped.  Coarse grid
c                operators and interpolation coefficients are calculated
c                and returned to the calling program.  No matrix solve.
c     ipc - Integer variable.
c           =0 or 1.
c           ipc is a multigrid parameter which determines the type of
c           interpolation to be used.  Usually ipc=1 is best.  However, if
c           the boundary contition equations have been absorbed into the
c           interior equations then ipc=0 can be used which results in a
c           slightly more efficient algorithm.
c    nman - Integer variable.
c           =0 usually.
c           =1 signals that the fine grid equations are singular for
c           the case when homogeneous Neumann boundary conditions are
c           applied along the entire boundary.  In this case, the
c           difference equations are singular and the condition that
c           the integral of q over the domain be zero is added to the
c           set of difference equations.  This condition is satisfied
c           by adding the appropriate constant vector to q on the fine
c           grid.  It is assumed, in this case, that a well-defined
c           problem has been given to mgss2, i.e. the integral of f
c           over the domain is zero.
c      im - Integer variable.
c           The number of grid points in the x-direction (including two
c           ficticious points)
c      jm - Integer variable.
c           The number of grid points in the y-direction (including two
c           ficticious points)
c    lout - Integer variable.
c           = unit number of output file into which the maximum norm
c             of the residual after each multigrid v-cycle is printed.
c             Use:  common /iout/ lout
c
c** INPUT/OUTPUT
c       q - Real array.  Dimensioned (id5)
c           On input, if ifmg=0, q contains the initial guess on the
c           finest grid for umgs2.  On output, q contains the final
c           solution on the finest grid.
c  ac-anw - Real arrays.  See DIMENSION.
c           On input, ac, aw, as, [asw and ase] contain the stencil
c           coefficients for the difference operator on the finest
c           grid.  When the iskip=1 option is used, these arrays
c           also are assumed to contain the coarse grid difference
c           stencil coeficients.
c           On output, when the iskip=0 option is used, the coarse
c           grid stencil coeficients are returned in ac - ase.
c
c ru,rd,rc - Real work arrays.  Dimensioned (idi)
c
c pu,pd,pc - Real work arrays.  Dimensioned (idi).
c           On input, when the iskip=1 option is used, these arrays
c           are assumed to contain the interpolation coefficients
c           used in the semi-coarsening multigrid algorithm.
c           On output, when the iskip=0 option is used, the
c           interpolation coeficients are returned in pu and pd.
c     np2 - Integer work array.  Dimensioned np2(20,8).
c           On input, when the iskip=1,-1 or -2 option is used, np2 is
c           assumed to contain the grid information for umgs2.
c           On output, when the iskip=0 option is used, the grid
c           information for umgs2 is returned in np2.
c** OUTPUT
c    rmax - If tol.ge.-1., the final residual norm is returned in rmax.
c
c** SUBROUTINES CALLED BY UMGS2
c
c    - ugrdfn, ukey, uintad, urelax, urscal, ursrhs, useta
c
c** END OF DESCRIPTION OF UMGS2
c .....................................................................
      CCTK_REAL ac(id5),aw(id5),as(id5),ae(id5),an(id5),asw(id9),
     + ase(id9),ane(id9),anw(id9),q(id5),f(id5)
      CCTK_REAL pu(idi),pd(idi),pc(idi),gam(im)
      integer np2(20,8)
      CCTK_REAL ru(idi),rd(idi),rc(idi)
      CCTK_REAL resid(0:40),confac(0:40)
      common /io/ linp,lout
      CCTK_REAL one
      parameter (one=1)
c
c-time           tsu0=second()
         if(iskip.eq.0) then
      call ugrdfn(m,ifd59,is5,is9,isi,np2,im,jm)
         iquit=0
           if(m.gt.20) then
      iquit=1
      write(lout,*) ' m=',m,' > 20 - np2 is dimensioned np2(m=20,8)'
           endif
           if(is5.gt.id5) then
      iquit=1
      write(lout,*) ' id5=',id5,' too small.  Should be set to',is5
           endif
           if(is9.gt.id9) then
      iquit=1
      write(lout,*) ' id9=',id9,' too small.  Should be set to',is9
           endif
           if(isi.gt.idi) then
      iquit=1
      write(lout,*) ' idi=',idi,' too small.  Should be set to',isi
            endif
            if(is5.lt.2*im*jm) then
      iquit=1
      write(lout,*) ' id5.lt.2*im*jm can cause problems in useta'
      write(lout,*) ' this can be remedied by setting id5 larger'
            endif
      if(iquit.eq.1) return
         endif
         if(iskip.le.0) then
c     ----------  interpolation and coarse grid operators -----------
      do 5 k=m-1,1,-1
cdir$ inline 
      call ukey(k+1,np2,n5,n9,ni,jm,i9,j9,ifd,jr)
      call ukey(k,np2,n5c,n9c,nic,jmc,i9c,j9c,ifdc,jrc)
cdir$ noinline 
      if(k.eq.m-1) n5cqf=n5c
    5 call useta(
     + ac(n5),aw(n5),as(n5),ae(n5),an(n5),asw(n9),ase(n9),
     + ane(n9),anw(n9),ac(n5c),aw(n5c),as(n5c),ae(n5c),an(n5c),asw(n9c),
     + ase(n9c),ane(n9c),anw(n9c),pu(nic),pd(nic),pc(nic),ru(nic),
     + rd(nic),rc(nic),q(n5cqf),f(n5cqf),gam,
     + im,jm,jmc,ifd,i9,j9,nman,k+1,m,jr,ipc,irc,irurd)
         endif
      if(iskip.eq.-2) return
c
         if(ifmg.ge.1) then
      do 6 k=m-1,1,-1
cdir$ inline 
      call ukey(k+1,np2,n5,n9,ni,jm,i9,j9,ifd,jr)
      call ukey(k,np2,n5c,n9c,nic,jmc,i9c,j9c,ifdc,jrc)
cdir$ noinline 
c     TODO 2009-01-06 Erik Schnetter <schnetter@cct.lsu.edu>:
c     I notice that this call does not correspond to the subroutine
c     definition below.  The call passes three arguments too many.
c     Maybe the three arguments pu(nic),pd(nic),pc(nic) should be
c     omitted?
c      call CCTK_WARN (CCTK_WARN_ABORT, "Trying to find out whether this line is reached")
c    6 call ursrhs(f(n5),f(n5c),pu(nic),pd(nic),pc(nic),ru(nic),
c     + rd(nic),rc(nic),im,jm,jmc,m,k+1,jr,irc)
    6 call ursrhs(f(n5),f(n5c),ru(nic),rd(nic),rc(nic),
     + im,jm,jmc,m,k+1,jr,irc)
         endif
c-time            tsu1=second()
c-time            write(lout,*) ' time for setup =',tsu1-tsu0
      l=1
      if(ifmg.eq.0) l=m
      k=l
      mcyc=0
      rmaxo=1.
c     ----------   begin multigrid cycling  ----------------------------
c
      if(l.eq.1) go to 20
cdir$ inline 
   10 call ukey(k,np2,n5,n9,ni,jm,i9,j9,ifd,jr)
cdir$ noinline 
      call urelax(
     + ac(n5),aw(n5),as(n5),ae(n5),an(n5),asw(n9),ase(n9),
     + ane(n9),anw(n9),f(n5),q(n5),gam,
     + im,jm,i9,j9,ifd,nman,k,m,jr,0,0)
cdir$ inline 
      call ukey(k-1,np2,n5c,n9c,nic,jmc,i9c,j9c,ifdc,jrc)
cdir$ noinline 
      call urscal(
     + ac(n5),aw(n5),as(n5),ae(n5),an(n5),asw(n9),ase(n9),
     + ane(n9),anw(n9),q(n5),f(n5),f(n5c),q(n5c),rc(nic),
     + im,jm,jmc,ifd,i9,j9,k,m,jr,tol,rmax,ipc,irc)
      if(k.eq.m.and.rmax.lt.tol) go to 60
         if(k.eq.m.and.tol.ge.-.5) then
      if(rmaxo.ne.0.) then
        rate=rmax/rmaxo
      else
        rate=1.
      endif
      rmaxo=rmax
      if(mcyc.eq.0) rmax0=rmax
      resid(mcyc)=rmax
      confac(mcyc)=rate
         endif
      if(tol.eq.-.5) write(lout,*) ' down ',k,rmax
      k=k-1
      if(k.gt.1) go to 10
c     ---------  solve coarsest grid  ----------------------------------
c
cdir$ inline 
   20 call ukey(1,np2,n5,n9,ni,jm,i9,j9,ifd,jr)
cdir$ noinline 
      call urelax(
     + ac(n5),aw(n5),as(n5),ae(n5),an(n5),asw(n9),ase(n9),
     + ane(n9),anw(n9),f(n5),q(n5),gam,
     + im,jm,i9,j9,ifd,nman,k,m,jr,0,0)
         if(l.eq.1) go to 40
c     ----------  interpolate correction to next finer grid  -----------
c
   30 k=k+1
cdir$ inline 
      call ukey(k,np2,n5,n9,ni,jm,i9,j9,ifd,jr)
      call ukey(k-1,np2,n5c,n9c,nic,jmc,i9c,j9c,ifdc,jrc)
cdir$ noinline 
      call uintad(
     + q(n5),q(n5c),pu(nic),pd(nic),im,jm,jmc,1,jr,ipc)
      call urelax(
     + ac(n5),aw(n5),as(n5),ae(n5),an(n5),asw(n9),ase(n9),
     + ane(n9),anw(n9),f(n5),q(n5),gam,
     + im,jm,i9,j9,ifd,nman,k,m,jr,0,0)
         if(tol.eq.-.5) then
      call urscal(
     + ac(n5),aw(n5),as(n5),ae(n5),an(n5),asw(n9),ase(n9),
     + ane(n9),anw(n9),q(n5),f(n5),f(n5c),q(n5c),rc(nic),
     + im,jm,jmc,ifd,i9,j9,k,m,jr,tol,rmax,ipc,irc)
      write(lout,*) ' up   ',k,rmax
         endif
      if(k.lt.l) go to 30
      if(l.eq.m) go to 50
c     ----------  interpolate solution to new finest grid l+1 in fmg  ----
c
   40 l=l+1
      k=l
cdir$ inline 
      call ukey(l,np2,n5,n9,ni,jm,i9,j9,ifd,jr)
      call ukey(l-1,np2,n5c,n9c,nic,jmc,i9c,j9c,ifdc,jrc)
cdir$ noinline 
      call uintad(
     + q(n5),q(n5c),pu(nic),pd(nic),im,jm,jmc,0,jr,0)
      go to 10
c
   50 if(nman.eq.1) call uneuman(q(n5),im,jm)
      mcyc=mcyc+1
c     ----------  Cycle ncyc times on grid m  ----------------------------
      if(mcyc.lt.ncyc) go to 10
c-time            tmg1=second()
c-time            write(lout,*) ' time in ',ncyc,' cycles =',tmg1-tsu1
c
c     ----------  print out final residual and work units  ---------------
        if(tol.ge.-1.) then
cdir$ inline 
      call ukey(m,np2,n5,n9,ni,jm,i9,j9,ifd,jr)
      call ukey(m-1,np2,n5c,n9c,nic,jmc,i9c,j9c,ifdc,jrc)
cdir$ noinline 
      call urscal(
     + ac(n5),aw(n5),as(n5),ae(n5),an(n5),asw(n9),ase(n9),
     + ane(n9),anw(n9),q(n5),f(n5),f(n5c),q(n5c),rc(nic),
     + im,jm,jmc,ifd,i9,j9,k,m,jr,one,rmax,ipc,irc)
      resid(mcyc)=rmax
      confac(mcyc)=rmax/rmaxo
      nb=0
      ne=min(6,mcyc)
 2029 write(lout,2033) (mc,mc=nb,ne)
      write(lout,2032) (resid(mc),mc=nb,ne)
      write(lout,2031) (confac(mc),mc=nb,ne)
      nb=ne+1
      ne=ne+min(6,mcyc-ne)
      if(nb.le.ne) go to 2029
      fconfac=(rmax/rmax0)**(1./dble(mcyc))
      write(lout,2034) fconfac
 2034 format(30x,6(1h*)/,' average convergence factor =',f7.3,/,
     + 30x,6(1h*))
 2033 format(7(4x,i2,4x))
 2031 format(7(1x,f9.3))
 2032 format(7(1x,e9.3))
         endif
      return
   60 write(lout,1003) mcyc,resid(mcyc),tol
      return
 1003 format(' cyc=',i2,' max(res)=',1pe8.2/
     + ' tolerance condition tol=',1pe8.2,' satisfied')
      end
c----------------------------------------------------------------------
      subroutine ugrdfn(m,ifd59,is5,is9,isi,np2,imx,jmx)
      implicit CCTK_REAL(a-h,o-z)
c----------------------------------------------------------------------
cdir$ noinline
c  Given imx, jmx and ifd59 (See comments in mgss2), ugrdfn calculates
c  the number of grids that will be needed.  Pointers into the arrays
c  ac, aw, as, asw, ase, q, f, pu, pd, pc, ru, rd and rc and the size
c  of each grid is calculated and stored in the array np2.  The 
c  subroutine ukey is called to retrieve the grid information.
c .....................................................................
      parameter(n5=1,n9=2,ni=3,jm=4,i9=5,j9=6,ifd=7,jred=8)
      integer np2(20,8)
      common /cs/ icorstr,iprint
      iq5=1
      iq9=1
      iqi=1
      m=1
      np2(m,1)=jmx
      np2(m,2)=3
   10 if(np2(m,1).le.3) go to 20
      m=m+1
      np2(m,1)=np2(m-1,1)/2+1
      if(np2(m-1,2).eq.2.and.mod(np2(m-1,1),2).eq.1)
     + np2(m,1)=np2(m,1)+1
      np2(m,2)=2
      go to 10
   20 do 30 k=1,m
      np2(m-k+1,jm)=np2(k,1)
   30 np2(m-k+1,jred)=np2(k,2)
      do 40 k=m,1,-1
      ktot=imx*np2(k,jm)
      np2(k,n5)=iq5
      iq5=iq5+ktot
      np2(k,n9)=iq9
      if(k.lt.m.or.ifd59.eq.9) iq9=iq9+ktot
      np2(k,ni)=iqi
   40 if(k.lt.m) iqi=iqi+ktot
      do 50 k=1,m
      np2(k,i9)=imx
      np2(k,j9)=np2(k,jm)
   50 np2(k,ifd)=9
         if(ifd59.eq.5) then
      np2(m,i9)=1
      np2(m,j9)=1
      np2(m,ifd)=5
         endif
      is5=iq5-1
      is9=iq9-1
      isi=iqi-1
      return
      end
c----------------------------------------------------------------------
      subroutine ukey(k,np2,nn5,nn9,nni,jjm,ii9,jj9,iifd,jjred)
      implicit CCTK_REAL(a-h,o-z)
c----------------------------------------------------------------------
c  Returns the grid pointers and dimension variables for grid k.  The
c  information is stored in the array np2.
c......................................................................
      parameter(n5=1,n9=2,ni=3,jm=4,i9=5,j9=6,ifd=7,jred=8)
      integer np2(20,8)
      nn5=np2(k,n5)
      nn9=np2(k,n9)
      nni=np2(k,ni)
      jjm=np2(k,jm)
      ii9=np2(k,i9)
      jj9=np2(k,j9)
      iifd=np2(k,ifd)
      jjred=np2(k,jred)
      return
      end
c----------------------------------------------------------------------
      subroutine uintad(q,qc,pu,pd,im,jm,jmc,iadd,jred,ipc)
      implicit CCTK_REAL (a-h,o-z)
c----------------------------------------------------------------------
c  iadd=1:
c  Interpolates and adds the coarse grid (kf-1) correction, qc, to the
c  fine grid (kf) approximation, q, at the black y-lines.
c  iadd=0:
c  In the full multigrid algorithm, the solution to the coarse grid
c  (kf-1) difference equation is interpolated to the fine grid (kf)
c  to be used as the initial guess vector for kf=2,3,...,m.
c  Interpolation is at black y-lines only.
c .....................................................................
      CCTK_REAL q(im,jm),qc(im,jmc),pu(im,jmc),pd(im,jmc)
      im1=im-1
      jm1=jm-1
      jblack=5-jred
c                                    add correction to next finer grid
         if(iadd.eq.1) then
      jc=3-jred
      do 10 j=jblack,jm1,2
      jc=jc+1
      do 10 i=2,im1
   10 q(i,j)=q(i,j)+pd(i,jc)*qc(i,jc)+pu(i,jc)*qc(i,jc+1)
c
c                       interpolate solution to next finer grid in fmg
         else
      jc=3-jred
      do 40 j=jblack,jm1,2
      jc=jc+1
      do 40 i=2,im1
   40 q(i,j)=pd(i,jc)*qc(i,jc)+pu(i,jc)*qc(i,jc+1)
         endif
      return
      end
c----------------------------------------------------------------------
      subroutine uneuman(q,im,jm)
      implicit CCTK_REAL (a-h,o-z)
c----------------------------------------------------------------------
c  For problems with homogeneous Neumann boundary contitions, the
c  condition that the integral of q over the domain be zero is added
c  to the set of difference equations in order to obtain a unique
c  solution.
c......................................................................
      CCTK_REAL q(im,jm)
      im1=im-1
      jm1=jm-1
      con=0.
      do 10 j=2,jm1
      do 10 i=2,im1
   10 con=con+q(i,j)
      con=con/((im-2)*(jm-2))
      do 20 j=2,jm1
      do 20 i=2,im1
   20 q(i,j)=q(i,j)-con
      return
      end
c----------------------------------------------------------------------
      subroutine urelax(ac,aw,as,ae,an,asw,ase,ane,anw,f,q,gam,
     + im,jm,i9,j9,ifd,nman,k,m,jred,ipc,iprcud)
      implicit CCTK_REAL (a-h,o-z)
c----------------------------------------------------------------------
c  Performs red/black x-line relaxation.  The Thomas algorithm is used
c  to solve the tridiagonal matrices.
c** INPUT -
c       ac-anw=  finite difference operator coeficients
c            q=  initial approximation
c            f=  right hand side vector
c        im,jm=  the number of grid points in the x,y-directions
c        i9,j9=  the i,j-dimensions of the arrays asw,ase
c          ifd=  5 or 9 - the size of the stencil
c         nman-  =0 usually.
c                =1 signals that the fine grid equations are singular
c                for the case when Neumann boundary conditions are
c                applied along the entire boundary.  In this case, the
c                equations on the coarsest grid (consisting of a single
c                line of unknowns) is a singular tridiagonal system
c                and the Thomas algorithm is modified on this grid to
c                obtain a solution with an arbitrary constant vector
c                component.  This constant vector is removed on the
c                finest grid by the call to subroutine uneuman.
c** OUTPUT -
c            q=  final approximation after a red/black relaxation sweep
c .....................................................................
      CCTK_REAL ac(im,jm),aw(im,jm),as(im,jm),ae(im,jm),an(im,jm),
     + asw(i9,j9),ase(i9,j9),ane(i9,j9),anw(i9,j9)
      CCTK_REAL f(im,jm),q(im,jm),gam(im)
      jm1=jm-1
      im1=im-1
      im2=im-2
      jblack=5-jred
c                                              usual red/black relaxatio
      nrel=2
      jrb=jred
c                                             ipc ..brbr relaxation swee
         if(iprcud.eq.1) then
      nrel=ipc
      if(mod(ipc,2).eq.0) jrb=jblack
c                                     1 black relax for calc g pu,pd,ru,
         elseif(iprcud.eq.2) then
      nrel=1
      jrb=jblack
         endif
c
c
      do 109 nrr=1,nrel
         if(jrb.eq.jblack) then
c                                                             black rela
         if(jblack.le.jm1) then
         if(iprcud.ne.2) then
c
      do 110 j=jblack,jm1,2
      do 110 i=2,im1
  110 q(i,j)=f(i,j)-as(i,j)*q(i,j-1)-an(i,j)*q(i,j+1)
         if(ifd.eq.9) then
      do 120 j=jblack,jm1,2
      do 120 i=2,im1
  120 q(i,j)=q(i,j)-asw(i,j)*q(i-1,j-1)-ase(i,j)*q(i+1,j-1)-
     + anw(i,j)*q(i-1,j+1)-ane(i,j)*q(i+1,j+1)
         endif
         endif
c                                                black tridiagonal solve
c**
c**  Moved calculation of loop 129 from loop 130 for vectorization
c**  on vector machines (ie. Cray)
c**  By: John Towns 2/6/92
c**
      do 129 j=jblack,jm1,2        
  129 q(2,j)=q(2,j)/ac(2,j)

c**
c**  Changed bet=(quantity) to bet=1./(quantity) to trade two divisions
c**  for one division and two multiplies (more efficient on all
c**  machines)
c**  By: John Towns 2/6/92
c**

c**
c**  Cray compiler directives to parallelize tridiagonal solve.
c**  By: John Towns 4/13/92
c**

cmic$ parallel  private(bet,gam,i)
cmic$1shared(ac,ae,aw,q,jblack,jm1,im1,im2)
cmic$ do parallel
      do 130 j=jblack,jm1,2
      bet=1./ac(2,j)
      do 140 i=3,im1
      gam(i)=ae(i-1,j)*bet
      bet=1./(ac(i,j)-aw(i,j)*gam(i))
  140 q(i,j)=(q(i,j)-aw(i,j)*q(i-1,j))*bet
      do 150 i=im2,2,-1
  150 q(i,j)=q(i,j)-gam(i+1)*q(i+1,j)
  130 continue
cmic$ end do
cmic$ end parallel
         endif
c                                                             red relax
         else
c
      do 210 j=jred,jm1,2
      do 210 i=2,im1
  210 q(i,j)=f(i,j)-as(i,j)*q(i,j-1)-an(i,j)*q(i,j+1)
         if(ifd.eq.9) then
      do 220 j=jred,jm1,2
      do 220 i=2,im1
  220 q(i,j)=q(i,j)-asw(i,j)*q(i-1,j-1)-ase(i,j)*q(i+1,j-1)-
     + anw(i,j)*q(i-1,j+1)-ane(i,j)*q(i+1,j+1)
         endif
c                                                      tridiagonal solve
c                          nman=1 ==> avoid singularity on coarsest grid
      imm=im1
          if(nman.eq.1.and.k.eq.1) then
      imm=im-2
      q(im1,2)=0.
      gam(im1)=0.
          endif
c
c**
c**  Moved calculation of loop 229 from loop 230 for vectorization
c**  on vector machines (ie. Cray)
c**  By: John Towns 2/6/92
c**
      do 229 j=jred,jm1,2
  229 q(2,j)=q(2,j)/ac(2,j)

c**
c**  Changed bet=(quantity) to bet=1./(quantity) to trade two divisions
c**  for one division and two multiplies (more efficient on all
c**  machines)
c**  By: John Towns 2/6/92
c**

c**
c**  Cray compiler directives to parallelize tridiagonal solve.
c**  By: John Towns 4/13/92
c**

cmic$ parallel  private(bet,gam,i) 
cmic$1shared(ac,ae,aw,q,jred,jm1,im2,imm)
cmic$ do parallel
      do 230 j=jred,jm1,2
      bet=1./ac(2,j)
      do 240 i=3,imm
      gam(i)=ae(i-1,j)*bet
      bet=1./(ac(i,j)-aw(i,j)*gam(i))
  240 q(i,j)=(q(i,j)-aw(i,j)*q(i-1,j))*bet
      do 250 i=im2,2,-1
  250 q(i,j)=q(i,j)-gam(i+1)*q(i+1,j)
  230 continue
cmic$ end do
cmic$ end parallel
         endif
      jrb=5-jrb
  109 continue
      return
      end
c----------------------------------------------------------------------
      subroutine urscal(
     + ac,aw,as,ae,an,asw,ase,ane,anw,q,f,fc,qc,rc,
     + im,jm,jmc,ifd,i9,j9,kf,m,jred,tol,rmax,ipc,irc)
      implicit CCTK_REAL (a-h,o-z)
c----------------------------------------------------------------------
c  Defines the grid kf-1 right hand side, fc, as the restriction of the
c  grid kf residual.  The restriction operator is the transpose of the
c  interpolation operator.  Note:  The grid kf residual is zero at the
c  black lines (j-direction) as a result of red/black relaxation.
c  Thus, the restriction is simple injection.  The initial guess, qc,
c  for the coarse grid correction equation is set to zero.  The
c  maximum norm of the residual is calculated and returned in rmax.
c......................................................................
      CCTK_REAL ac(im,jm),aw(im,jm),as(im,jm),ae(im,jm),an(im,jm),
     + asw(i9,j9),ase(i9,j9),ane(i9,j9),anw(i9,j9)
      CCTK_REAL f(im,jm),q(im,jm),fc(im,jmc),qc(im,jmc)
      CCTK_REAL rc(im,jmc)
      rmax=0.
      im1=im-1
      jm1=jm-1
      jmc1=jmc-1
      jc=1
      do 10 j=jred,jm1,2
      jc=jc+1
      do 10 i=2,im1
   10 fc(i,jc)=f(i,j)-as(i,j)*q(i,j-1)-an(i,j)*q(i,j+1)-
     + aw(i,j)*q(i-1,j)-ae(i,j)*q(i+1,j)-ac(i,j)*q(i,j)
         if(ifd.eq.9) then
      jc=1
      do 20 j=jred,jm1,2
      jc=jc+1
      do 20 i=2,im1
   20 fc(i,jc)=fc(i,jc)-asw(i,j)*q(i-1,j-1)-ane(i,j)*q(i+1,j+1)-
     + ase(i,j)*q(i+1,j-1)-anw(i,j)*q(i-1,j+1)
         endif
c                                           zero out qc as initial guess
      do 25 jc=1,jmc
      do 25 i=1,im
   25 qc(i,jc)=0.
c                                        if kf=m calculate residual norm
         if((kf.eq.m.and.tol.ge.0.).or.tol.eq.-.5) then
      do 30 jc=2,jmc1
      do 30 i=2,im1
      resmax=abs(fc(i,jc))
   30 if(resmax.gt.rmax) rmax=resmax
         endif
c                                                 weight rhs if irc.ge.1
         if(irc.eq.1.and.ipc.ge.1) then
      do 40 jc=2,jmc1
      do 40 i=2,im1
   40 fc(i,jc)=rc(i,jc)*fc(i,jc)
         endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine ursrhs(f,fc,ru,rd,rc,im,jm,jmc,m,kf,jred,irc)
      implicit CCTK_REAL (a-h,o-z)
c----------------------------------------------------------------------
c  Restricts the right hand side vector on grid kf onto grid kf-1 when
c  the full multigrid (ifmg>0) option is used.  The restriction operator
c  is NOT necessarily the transpose of the interpolation operator.
c......................................................................
      CCTK_REAL f(im,jm),fc(im,jmc),ru(im,jmc),rd(im,jmc),rc(im,jmc)
      jm1=jm-1
      im1=im-1
      jc=1
         if(irc.eq.0) then
      do 10 j=jred,jm1,2
      jc=jc+1
      do 10 i=2,im1
   10 fc(i,jc)=ru(i,jc-1)*f(i,j-1)+rd(i,jc)*f(i,j+1)+f(i,j)
         else
      do 20 j=jred,jm1,2
      jc=jc+1
      do 20 i=2,im1
   20 fc(i,jc)=ru(i,jc-1)*f(i,j-1)+rd(i,jc)*f(i,j+1)+
     + rc(i,jc)*f(i,j)
         endif
      return
      end
c----------------------------------------------------------------------
      subroutine useta(
     + ac,aw,as,ae,an,asw,ase,ane,anw,acc,awc,asc,aec,
     + anc,aswc,asec,anec,anwc,pu,pd,pc,ru,rd,rc,qw,fw,gam,
     + im,jm,jmc,ifd,i9,j9,nman,kf,m,jred,ipc,irc,irurd)
      implicit CCTK_REAL (a-h,o-z)
c----------------------------------------------------------------------
cdir$ noinline
c     Calculates the interpolation coefficients from grid kf-1 to
c     grid kf and the coarse grid operator on grid kf-1.
c** INPUT -
c    ac - anw = fine grid (kf) array stencil coeficients
c            m=  total number of grids
c           kf=  grid number of the fine grid
c          ifd=  the size of the fine grid stencil (= 5 or 9)
c        i9,j9=  the i,j-dimensions of the arrays asw,ase
c        qw,fw=  coarse grid portions of q and f used for work arrays here
c   (See comments in MGSS2 for details)
c** OUTPUT -
c  acc - anwc = coarse grid (kf-1) array stencil coeficients
c        pu,pd=  arrays of interpolation coefficients from grid kf-1
c                to grid kf
c .....................................................................
      CCTK_REAL ac(im,jm),aw(im,jm),as(im,jm),ae(im,jm),an(im,jm),
     + asw(i9,j9),ase(i9,j9),ane(i9,j9),anw(i9,j9),
     + ru(im,jmc),rd(im,jmc),rc(im,jmc),
     + pu(im,jmc),pd(im,jmc),pc(im,jmc),gam(im)
      CCTK_REAL acc(im,jmc),awc(im,jmc),asc(im,jmc),aec(im,jmc),
     + anc(im,jmc),aswc(im,jmc),asec(im,jmc),anec(im,jmc),anwc(im,jmc)
      CCTK_REAL qw(im,jm),fw(im,jm)
      common /io/ linp,lout
      common /prsol/ iprsol
c
      pcscale=.001
c
      im1=im-1
      jm1=jm-1
      jmc1=jmc-1
      jblack=5-jred
c                           zeroing out connections to fictitious points
      do 1 j=1,jm
      do 2 i=1,im,im1
      ac(i,j)=0.
      aw(i,j)=0.
      as(i,j)=0.
      ae(i,j)=0.
    2 an(i,j)=0.
      aw(2,j)=0.
    1 ae(im1,j)=0.
      do 3 i=1,im
      do 4 j=1,jm,jm1
      ac(i,j)=0.
      aw(i,j)=0.
      as(i,j)=0.
      ae(i,j)=0.
    4 an(i,j)=0.
      as(i,2)=0.
    3 an(i,jm1)=0.
         if(ifd.eq.9) then
      do 5 j=1,jm
      do 6 i=1,im,im1
      asw(i,j)=0.
      ase(i,j)=0.
      ane(i,j)=0.
    6 anw(i,j)=0.
      asw(2,j)=0.
      anw(2,j)=0.
      ase(im1,j)=0.
    5 ane(im1,j)=0.
      do 7 i=1,im
      do 8 j=1,jm,jm1
      asw(i,j)=0.
      ase(i,j)=0.
      ane(i,j)=0.
    8 anw(i,j)=0.
      ase(i,2)=0.
      asw(i,2)=0.
      ane(i,jm1)=0.
    7 anw(i,jm1)=0.
      endif
c
      do 9 jc=1,jmc
      do 9 i=1,im
      pc(i,jc)=0.
      pu(i,jc)=0.
      pd(i,jc)=0.
      rc(i,jc)=0.
      ru(i,jc)=0.
    9 rd(i,jc)=0.
c
c                               calculation of interpolation coeficients
c

c                                                              define pc
         if(ipc.ge.1) then
      do 20 j=2,jm1
      do 20 i=2,im1
      fw(i,j)=0.
   20 qw(i,j)=1.
c
      call urelax(ac,aw,as,ae,an,asw,ase,ane,anw,fw,qw,gam,im,jm,
     + i9,j9,ifd,nman,kf,m,jred,ipc,1)
c                                                              scale pc
      pcmax=0.
      jc=1
      do 40 j=jred,jm1,2
      jc=jc+1
      do 40 i=2,im1
      pc(i,jc)=qw(i,j)
   40 pcmax=max(pcmax,abs(qw(i,j)))
      do 50 jc=2,jmc1
      do 50 i=2,im1
      if(pc(i,jc).eq.0.) pc(i,jc)=pcscale
   50 pc(i,jc)=pc(i,jc)/pcmax
c
         else
      do 55 jc=2,jmc1
      do 55 i=2,im1
   55 pc(i,jc)=1.
         endif
c
c                                                              define pu
      jc=3-jred
      do 60 j=jblack,jm1,2
      jc=jc+1
         if(ipc.eq.0) then
      do 70 i=2,im1
   70 qw(i,j)=-an(i,j)
         if(ifd.eq.9) then
      do 80 i=2,im1
   80 qw(i,j)=qw(i,j)-ane(i,j)-anw(i,j)
         endif
         else
      do 90 i=2,im1
   90 qw(i,j)=-an(i,j)*pc(i,jc+1)
         if(ifd.eq.9) then
      do 100 i=2,im1
  100 qw(i,j)=qw(i,j)-ane(i,j)*pc(i+1,jc+1)-anw(i,j)*pc(i-1,jc+1)
         endif
         endif
   60 continue
c                                                          solve for pu
      call urelax(ac,aw,as,ae,an,asw,ase,ane,anw,fw,qw,gam,im,jm,
     + i9,j9,ifd,nman,kf,m,jred,ipc,2)
c

      jc=3-jred
      do 102 j=jblack,jm1,2
      jc=jc+1
         if(j.lt.jm1) then
      do 103 i=2,im1
  103 pu(i,jc)=qw(i,j)
         endif
  102 continue
c
c                                                              define pd
      jc=3-jred
      do 106 j=jblack,jm1,2
      jc=jc+1
         if(ipc.eq.0) then
      do 130 i=2,im1
  130 qw(i,j)=-as(i,j)
         if(ifd.eq.9) then
      do 140 i=2,im1
  140 qw(i,j)=qw(i,j)-ase(i,j)-asw(i,j)
         endif
c
         else
c
      do 150 i=2,im1
  150 qw(i,j)=-as(i,j)*pc(i,jc)
         if(ifd.eq.9) then
      do 160 i=2,im1
  160 qw(i,j)=qw(i,j)-ase(i,j)*pc(i+1,jc)-asw(i,j)*pc(i-1,jc)
         endif
         endif
  106 continue
c                                                          solve for pd
      call urelax(ac,aw,as,ae,an,asw,ase,ane,anw,fw,qw,gam,im,jm,
     + i9,j9,ifd,nman,kf,m,jred,ipc,2)
c
      jc=3-jred
      do 105 j=jblack,jm1,2
      jc=jc+1
         if(j.gt.2) then
      do 104 i=2,im1
  104 pd(i,jc)=qw(i,j)
         endif
  105 continue
c
c                                            define restriction operator
c
c                                                              define rc
         if(irc.eq.1) then
      do 500 jc=2,jmc1
      do 500 i=2,im1
  500 rc(i,jc)=pc(i,jc)
         else
      do 502 jc=2,jmc1
      do 502 i=2,im1
  502 rc(i,jc)=1.
         endif
c   
c                                           compute qw = -Cb(inv) * eb*
         if(irurd.ge.1) then
      jc=3-jred
         if(irurd.eq.1) then
      do 560 j=jblack,jm1,2
      jc=jc+1
      do 560 i=2,im1
  560 qw(i,j)=1.
         elseif(irurd.eq.2) then
      do 561 j=jblack,jm1,2
      jc=jc+1
      do 561 i=2,im1
  561 qw(i,j)=(pd(i,jc)*pc(i,jc)+pu(i,jc)*pc(i,jc+1))
         endif
c
      call urelax(ac,aw,as,ae,an,asw,ase,ane,anw,fw,qw,gam,im,jm,
     + i9,j9,ifd,nman,kf,m,jred,ipc,2)
c
      jc=3-jred
      do 566 j=jblack,jm1,2
      jc=jc+1
c                                           compute ru = -b(j+1) * qw
         if(j.lt.jm1) then
      do 570 i=2,im1
  570 ru(i,jc)=-as(i,j+1)*qw(i,j)
         if(ifd.eq.9) then
      do 580 i=2,im1
  580 ru(i,jc)=ru(i,jc)-ase(i,j+1)*qw(i+1,j)-asw(i,j+1)*qw(i-1,j)
         endif
         endif
c                             compute rd = -a(j-1) * c(j)(inv) * qw
         if(j.gt.2) then
      do 650 i=2,im1
  650 rd(i,jc)=-an(i,j-1)*qw(i,j)
         if(ifd.eq.9) then
      do 660 i=2,im1
  660 rd(i,jc)=rd(i,jc)-ane(i,j-1)*qw(i+1,j)-anw(i,j-1)*qw(i-1,j)
         endif
         endif
  566 continue
c
         else
c                                              else set ru=pu and rd=pd
      jc=3-jred
      do 670 j=jblack,jm1,2
      jc=jc+1
      do 670 i=2,im1
      ru(i,jc)=pu(i,jc)
  670 rd(i,jc)=pd(i,jc)
         endif
c
c                                   calculating the coarse grid operator
c
         if(ipc+irc+irurd.eq.0) then
      j=jred-2
      do 200 jc=2,jmc1
      j=j+2
      do 200 i=2,im1
      acc(i,jc)=ac(i,j)+an(i,j-1)*pu(i,jc-1)+as(i,j+1)*pd(i,jc)+
     + pu(i,jc-1)*(as(i,j)+ac(i,j-1)*pu(i,jc-1))+
     + pd(i,jc)*(an(i,j)+ac(i,j+1)*pd(i,jc))
      awc(i,jc)=aw(i,j)+pd(i-1,jc)*aw(i,j+1)*pd(i,jc)+pu(i-1,jc-1)*
     + aw(i,j-1)*pu(i,jc-1)
      asc(i,jc)=as(i,j)*pd(i,jc-1)+pu(i,jc-1)*(as(i,j-1)+
     + ac(i,j-1)*pd(i,jc-1))
      aec(i,jc)=ae(i,j)+pd(i+1,jc)*ae(i,j+1)*pd(i,jc)+pu(i+1,jc-1)*
     + ae(i,j-1)*pu(i,jc-1)
      anc(i,jc)=an(i,j)*pu(i,jc)+pd(i,jc)*(an(i,j+1)+
     + ac(i,j+1)*pu(i,jc))
      aswc(i,jc)=pd(i-1,jc-1)*aw(i,j-1)*pu(i,jc-1)
      asec(i,jc)=pd(i+1,jc-1)*ae(i,j-1)*pu(i,jc-1)
      anec(i,jc)=pu(i+1,jc)*ae(i,j+1)*pd(i,jc)
  200 anwc(i,jc)=pu(i-1,jc)*aw(i,j+1)*pd(i,jc)
         if(ifd.eq.9) then
      j=jred-2
      do 210 jc=2,jmc1
      j=j+2
      do 210 i=2,im1
      awc(i,jc)=awc(i,jc)+asw(i,j+1)*pd(i,jc)+anw(i,j-1)*pu(i,jc-1)+
     + pd(i-1,jc)*anw(i,j)+pu(i-1,jc-1)*asw(i,j)
      aec(i,jc)=aec(i,jc)+ase(i,j+1)*pd(i,jc)+ane(i,j-1)*pu(i,jc-1)+
     + pd(i+1,jc)*ane(i,j)+pu(i+1,jc-1)*ase(i,j)
      aswc(i,jc)=aswc(i,jc)+asw(i,j-1)*pu(i,jc-1)+pd(i-1,jc-1)*asw(i,j)
      asec(i,jc)=asec(i,jc)+ase(i,j-1)*pu(i,jc-1)+pd(i+1,jc-1)*ase(i,j)
      anec(i,jc)=anec(i,jc)+ane(i,j+1)*pd(i,jc)+pu(i+1,jc)*ane(i,j)
  210 anwc(i,jc)=anwc(i,jc)+anw(i,j+1)*pd(i,jc)+pu(i-1,jc)*anw(i,j)
         endif
c
         else
c
      j=jred-2
      do 300 jc=2,jmc1
      j=j+2
      do 300 i=2,im1
      acc(i,jc)=rc(i,jc)*(ac(i,j)*pc(i,jc)+
     +                    as(i,j)*pu(i,jc-1)+
     +                    an(i,j)*pd(i,jc))+
     +        ru(i,jc-1)*(ac(i,j-1)*pu(i,jc-1)+
     +                    an(i,j-1)*pc(i,jc))+
     +          rd(i,jc)*(ac(i,j+1)*pd(i,jc)+
     +                    as(i,j+1)*pc(i,jc))
      awc(i,jc)=rc(i,jc)*aw(i,j)*pc(i-1,jc)+
     +          rd(i,jc)*aw(i,j+1)*pd(i-1,jc)+
     +        ru(i,jc-1)*aw(i,j-1)*pu(i-1,jc-1)
      asc(i,jc)=rc(i,jc)*as(i,j)*pd(i,jc-1)+
     +       ru(i,jc-1)*(ac(i,j-1)*pd(i,jc-1)+
     +                   as(i,j-1)*pc(i,jc-1))
      aec(i,jc)=rc(i,jc)*ae(i,j)*pc(i+1,jc)+
     +          rd(i,jc)*ae(i,j+1)*pd(i+1,jc)+
     +        ru(i,jc-1)*ae(i,j-1)*pu(i+1,jc-1)
      anc(i,jc)=rc(i,jc)*an(i,j)*pu(i,jc)+
     +         rd(i,jc)*(ac(i,j+1)*pu(i,jc)+
     +                   an(i,j+1)*pc(i,jc+1))
      aswc(i,jc)=ru(i,jc-1)*aw(i,j-1)*pd(i-1,jc-1)
      asec(i,jc)=ru(i,jc-1)*ae(i,j-1)*pd(i+1,jc-1)
      anec(i,jc)=rd(i,jc)*ae(i,j+1)*pu(i+1,jc)
  300 anwc(i,jc)=rd(i,jc)*aw(i,j+1)*pu(i-1,jc)
         if(ifd.eq.9) then
      j=jred-2
      do 310 jc=2,jmc1
      j=j+2
      do 310 i=2,im1
      awc(i,jc)=awc(i,jc)+(rd(i,jc)*asw(i,j+1)+
     +                   ru(i,jc-1)*anw(i,j-1))*pc(i-1,jc)+
     +                    rc(i,jc)*(anw(i,j)*pd(i-1,jc)+
     +                              asw(i,j)*pu(i-1,jc-1))
      aec(i,jc)=aec(i,jc)+(rd(i,jc)*ase(i,j+1)+
     +                   ru(i,jc-1)*ane(i,j-1))*pc(i+1,jc)+
     +                    rc(i,jc)*(ane(i,j)*pd(i+1,jc)+
     +                              ase(i,j)*pu(i+1,jc-1))
      aswc(i,jc)=aswc(i,jc)+ru(i,jc-1)*asw(i,j-1)*pc(i-1,jc-1)+
     +                        rc(i,jc)*asw(i,j)*pd(i-1,jc-1)
      asec(i,jc)=asec(i,jc)+ru(i,jc-1)*ase(i,j-1)*pc(i+1,jc-1)+
     +                        rc(i,jc)*ase(i,j)*pd(i+1,jc-1)
      anec(i,jc)=anec(i,jc)+rd(i,jc)*ane(i,j+1)*pc(i+1,jc+1)+
     +                      rc(i,jc)*ane(i,j)*pu(i+1,jc)
  310 anwc(i,jc)=anwc(i,jc)+rd(i,jc)*anw(i,j+1)*pc(i-1,jc+1)+
     +                      rc(i,jc)*anw(i,j)*pu(i-1,jc)
         endif
         endif
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
         if(iprsol.eq.2.and.kf.eq.m.and.ifd.eq.5) then
      do 111 j=2,jm1
      do 111 i=2,im1
               write(lout,1010) im,jm,an(i,j)
               write(lout,1012) i,j,aw(i,j),ac(i,j),ae(i,j)
  111          write(lout,1011) as(i,j)
 1010 format(2(1x,i2),14x,f12.5)
 1011 format(20x,f12.5)
 1012 format(2(1x,i2),3(1x,f12.5))
          endif
         if(iprsol.eq.2.and.kf.eq.m.and.ifd.eq.9) then
      do 115 j=2,jm1
      do 115 i=2,im1
               write(lout,1017) im,jm,anw(i,j),an(i,j),ane(i,j)
               write(lout,1017) i,j,aw(i,j),ac(i,j),ae(i,j)
  115          write(lout,1016) asw(i,j),as(i,j),ase(i,j)
 1016  format(6x,3(1x,f12.5))
 1017  format(2(1x,i2),3(1x,f12.5))
          endif
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      if(iprsol.eq.2.or.iprsol.eq.3) then
      write(lout,*) ' coarse grid kf-1 ==',kf-1
      do 211 jc=2,jmc1
      do 211 i=2,im1
      write(lout,2015) im,jmc,anwc(i,jc),anc(i,jc),anec(i,jc),pd(i,jc),
     + rd(i,jc)
      write(lout,2013) i,jc,awc(i,jc),acc(i,jc),aec(i,jc),pc(i,jc),
     + rc(i,jc)
      write(lout,2014) aswc(i,jc),asc(i,jc),asec(i,jc),pu(i,jc-1),
     + ru(i,jc-1)
  211 write(lout,*) '                          m, kf-1=',m,kf-1
 2014 format(9x,3(1x,f11.5),3x,2(f11.5,1x))
 2013 format(3x,2(1x,i2),3(1x,f11.5),3x,2(f11.5,1x))
 2015 format(3x,2(1x,i2),3(1x,f11.5),3x,2(f11.5,1x))
          endif
cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
      return
      end
c**********************************************************************
      subroutine uoutpt(q,im,jm)
      implicit CCTK_REAL (a-h,o-z)
c**********************************************************************
c  Sample output subroutine.  Prints out the values of q at the
c  interior points of the finest grid.
c**********************************************************************
      common /io/ linp,lout
      CCTK_REAL q(im,jm)
      im1=im-1
      jm1=jm-1
      ie=1
   20 ib=ie+1
      ie=ib+min(5,im1-ib)
      do 10 j=jm1,2,-1
   10 write(lout,100) j,(q(i,j),i=ib,ie)
      if(ie.lt.im1) go to 20
  100 format(1x,i2,1x,6(1x,f10.4))
      return
      end
c**********************************************************************
      subroutine uputf(ac,aw,as,ae,an,f,nx,ny,
     + lo,nxd,nyd,i32su)
      implicit CCTK_REAL (a-h,o-z)
c**********************************************************************
      CCTK_REAL ac(lo:nxd,lo:nyd),aw(lo:nxd,lo:nyd),
     + as(lo:nxd,lo:nyd),ae(lo:nxd,lo:nyd),
     + an(lo:nxd,lo:nyd),f(lo:nxd,lo:nyd)
      CCTK_REAL a(20),b(20),ab(20)
      integer il(20),ir(20),jb(20),jt(20)
      integer ibc(4)
      common /io/ linp,lout
c
c dcell is the value assigned to the diagonal element of a dead
c cell, i.e. a cell that has 0 conections to all its neighbors.
c icendif determines the differencing scheme for the first order terms
c icendif=0 - central differencing, =1 - forward differencing.
c
      dcell = 1.
      do 321 j=lo,nyd
      do 321 i=lo,nxd
      ac(i,j)=0.
      aw(i,j)=0.
      as(i,j)=0.
      ae(i,j)=0.
  321 an(i,j)=0.
c
      nx1=nx+1
      ny1=ny+1
      read(linp,*) icendif
      read(linp,*) ibc(1),ibc(2),ibc(3),ibc(4)
      read(linp,*) nreg
      hx=1./nx
      hy=1./ny
      hx2=hx*hx
      hy2=hy*hy
      hxy2=hx2*hy2
      dcell=hxy2*dcell
      write(lout,1011) ibc(1),ibc(2),ibc(3),ibc(4),icendif,dcell,hx,hy
 1011 format(' ibc_l ibc_b ibc_r ibc_t   icendiff   dcell   hx      hy'/
     + 4x,i1,5x,i1,5x,i1,5x,i1,7x,i1,6x,e8.2,2x,f6.4,2x,f6.4/)
c
      do 10 irg=1,nreg
      read(linp,*) il(irg),ir(irg),jb(irg),jt(irg)
      read(linp,*) xk,yk,sreg,freg
      read(linp,*) a(irg),b(irg),ab(irg)
      write(lout,1000) il(irg),ir(irg),jb(irg),jt(irg),xk,yk,sreg,freg
 1000 format(1x,i3,',',i3,' X ',i3,',',i3,2x,1pe8.2,1x,1pe8.2,2x,
     + 1pe8.1,1x,1pe8.1)
      write(lout,1001) a(irg),b(irg),ab(irg)
 1001 format(17x,' a=',1pe10.3,'  b=',1pe10.3,' ab=',1pe10.3)
      xk=xk*hy2
      yk=yk*hx2
      sreg=sreg*hxy2
      freg=freg*hxy2
      a(irg)=a(irg)*hx2*hy
      b(irg)=b(irg)*hx*hy2
      ab(irg)=ab(irg)*hx*hy
         if(icendif.eq.0) then
      a(irg)=a(irg)/2.
      b(irg)=b(irg)/2.
      ab(irg)=ab(irg)/4.
         endif
      if(il(irg).eq.1) il(irg)=0
      if(ir(irg).eq.nx) ir(irg)=nx1
      if(jb(irg).eq.1) jb(irg)=0
      if(jt(irg).eq.ny) jt(irg)=ny1
      do 20 i=il(irg),ir(irg)
      do 20 j=jb(irg),jt(irg)
      aw(i,j)=xk
      as(i,j)=yk
      ac(i,j)=sreg
   20 f(i,j)=freg
   10 continue
      write(lout,*) ' - - - - - - - - - - - - - - - - - - - - - - - - -'
c                             defining coeficients by harmonic averaging
      do 30 i=1,nx
      asio=as(i,0)
      do 30 j=1,ny1
      aa=as(i,j)*asio
         if(aa.gt.0.) then
      t=2.*aa/(as(i,j)+asio)
      asio=as(i,j)
      as(i,j)=t
         else
      asio=as(i,j)
      as(i,j)=0.
         endif
   30 continue
      do 40 j=1,ny
      awoj=aw(0,j)
      do 40 i=1,nx1
      aa=aw(i,j)*awoj
         if(aa.gt.0.) then
      t=2.*aa/(aw(i,j)+awoj)
      awoj=aw(i,j)
      aw(i,j)=t
         else
      awoj=aw(i,j)
      aw(i,j)=0.
         endif
   40 continue
      do 45 i=0,nx
      do 45 j=0,ny
      ae(i,j)=aw(i+1,j)
   45 an(i,j)=as(i,j+1)
      do 50 i=1,nx
      do 50 j=1,ny
      ac(i,j)=ac(i,j)-aw(i,j)-as(i,j)-ae(i,j)-
     + an(i,j)
   50 if(ac(i,j).eq.0.) ac(i,j)=dcell
c                                        adding on the unsymmetric terms
      do 51 irg=1,nreg
c                                           icendif=0 ==> central diff g
         if(icendif.eq.0) then
      do 52 i=il(irg),ir(irg)
      do 52 j=jb(irg),jt(irg)
      aw(i,j)=aw(i,j)-a(irg)
      ae(i,j)=ae(i,j)+a(irg)
      an(i,j)=an(i,j)+b(irg)
   52 as(i,j)=as(i,j)-b(irg)
c                                        icendif=1 ==> upstream diff s
         elseif(icendif.eq.1) then
      do 54 i=il(irg),ir(irg)
      do 54 j=jb(irg),jt(irg)
      ac(i,j)=ac(i,j)-a(irg)
      ae(i,j)=ae(i,j)+a(irg)
      an(i,j)=an(i,j)+b(irg)
   54 ac(i,j)=ac(i,j)-b(irg)
         endif
   51 continue
c                           set boundary conditions for 5 point operator
      do 60 j=1,ny
c                                                          left boundary
      ae(0,j)=aw(1,j)
         if(ibc(1).eq.1) then
      ac(0,j)=aw(1,j)
      f(0,j)=2.*aw(1,j)*0.0
         elseif(ibc(1).eq.2) then
      ac(0,j)=-aw(1,j)
      f(0,j)=hx*aw(1,j)*0.0
         endif
         if(ac(0,j).eq.0.) then
      ae(0,j)=0.
      ac(0,j)=dcell
      f(0,j)=0.
         endif
c                                                         right boundary
      aw(nx1,j)=ae(nx,j)
         if(ibc(3).eq.1) then
      ac(nx1,j)=ae(nx,j)      
      f(nx1,j)=2.*ae(nx,j)*0.
         elseif(ibc(3).eq.2) then
      ac(nx1,j)=-ae(nx,j)
      f(nx1,j)=hx*ae(nx,j)*0.
         endif
         if(ac(nx1,j).eq.0.) then
      aw(nx1,j)=0.
      ac(nx1,j)=dcell
      f(nx1,j)=0.
         endif
   60 continue
c
      do 80 i=1,nx
c                                                         lower boundary
      an(i,0)=as(i,1)
         if(ibc(2).eq.1) then
      ac(i,0)=as(i,1)
      f(i,0)=2.*as(i,1)*0.
         elseif(ibc(2).eq.2) then
      ac(i,0)=-as(i,1)
      f(i,0)=hy*as(i,1)*0.
         endif
         if(ac(i,0).eq.0.) then
      an(i,0)=0.
      ac(i,0)=dcell
      f(i,0)=0.
         endif
c                                                         upper boundary
      as(i,ny1)=an(i,ny)
         if(ibc(4).eq.1) then
      ac(i,ny1)=an(i,ny)
      f(i,ny1)=2.*an(i,ny)*0.
         elseif(ibc(4).eq.2) then
      ac(i,ny1)=-an(i,ny)
      f(i,ny1)=2.*an(i,ny)*0.
         endif
         if(ac(i,ny1).eq.0.) then
      as(i,ny1)=0.
      ac(i,ny1)=dcell
      f(i,ny1)=0.
         endif
   80 continue
c                     connections between ghost boundary points zeroed
      do 83 j=1,ny1
      as(0,j)=0.
      an(0,j-1)=0.
      as(nx1,j)=0.
   83 an(nx1,j-1)=0.
      do 86 i=1,nx1
      aw(i,0)=0.
      ae(i-1,0)=0.
      aw(i,ny1)=0.
   86 ae(i-1,ny1)=0.
c                                        corner stencils and rhs defined
         if(i32su.eq.32) then
      do 90 j=0,ny1,ny1
      do 90 i=0,nx1,nx1
      ac(i,j)=dcell
      aw(i,j)=0.
      ae(i,j)=0.
      as(i,j)=0.
      an(i,j)=0.
   90 f(i,j)=0.
         endif
c                                i32su=22 - boundary conditions absorbed
         if(i32su.eq.22) then
      do 100 j=1,ny
      awac=aw(1,j)/ac(0,j)
      ac(1,j)=ac(1,j)-awac*ae(0,j)
      aw(1,j)=0.
      f(1,j)=f(1,j)-awac*f(0,j)
      ac(0,j)=0.
      ae(0,j)=0.
      f(0,j)=0
      awac=aw(nx1,j)/ac(nx1,j)
      ac(nx,j)=ac(nx,j)-awac*ae(nx1,j)
      ae(nx,j)=0.
      f(nx,j)=f(nx,j)-awac*f(nx1,j)
      ac(nx1,j)=0.
      aw(nx1,j)=0.
  100 f(nx1,j)=0.
c
      do 110 i=1,nx
      asac=as(i,1)/ac(i,0)
      ac(i,1)=ac(i,1)-asac*an(i,0)
      as(i,1)=0.
      f(i,1)=f(i,1)-asac*f(i,0)
      ac(i,0)=0.
      an(i,0)=0.
      f(i,0)=0.
      anac=an(i,ny)/ac(i,ny1)
      ac(i,ny)=ac(i,ny)-anac*as(i,ny1)
      an(i,ny)=0.
      f(i,ny)=f(i,ny)-anac*f(i,ny1)
      ac(i,ny1)=0.
      as(i,ny1)=0.
  110 f(i,ny1)=0.
         endif
      return
      end

```

bhbrill.x:
```
        o1 = dq**2
        o2 = 1/o1
        o3 = 1/dq
        o4 = tan(qgrd(j))
        o5 = 1/o4
        o6 = deta**2
        o7 = 1/o6
        o8 = sin(qgrd(j))
        o9 = o8**2
        o10 = 1/o9
        o11 = cos(qgrd(j))
        o12 = o11**2
        o13 = etagrd(i)**2
        o14 = sigma**2
        o15 = 1/o14
        o16 = -(o13*o15)
        o17 = -2.00000000000000d0*etagrd(i)*eta0*o15
        o18 = eta0**2
        o19 = -(o15*o18)
        o20 = o16 + o17 + o19
        o21 = exp(o20)
        i22 = -2 + n
c       The next lines causes a floating point exception on Alphas,
c       if o22 is 0.0 but o8 is negative.
c       This is because of y**x = exp(x*ln(y)).
c       Changing the type of the exponent to integer fixes the problem.
c        o22 = -2.00000000000000d0 + n
c        o23 = o8**o22
        o23 = o8**i22
        o24 = n**2
        o25 = 2.00000000000000d0*etagrd(i)*eta0*o15
        o26 = o16 + o19 + o25
        o27 = exp(o26)
        o28 = o8**n
        o29 = o14**2
        o30 = 1/o29
        o31 = o4**2
        o32 = 1/o31
        o33 = 5.0000000000000d-1*etagrd(i)
        o34 = cosh(o33)
        Cn(i,j) = o2 + 5.0000000000000d-1*o3*o5
        Cs(i,j) = o2 - 5.0000000000000d-1*o3*o5
        Cw(i,j) = o7
        Cc(i,j) = -1.25000000000000d-1 - 1.25000000000000d-1*o10 - 2.000
     &  00000000000d0*o2 - 2.50000000000000d-1*amp*n*o12*o21*o23 + 2.500
     &  00000000000d-1*amp*o12*o21*o23*o24 - 2.50000000000000d-1*amp*n*o
     &  12*o23*o27 + 2.50000000000000d-1*amp*o12*o23*o24*o27 - 2.5000000
     &  0000000d-1*amp*n*o21*o28 - 5.0000000000000d-1*amp*o15*o21*o28 - 
     &  2.50000000000000d-1*amp*n*o27*o28 - 5.0000000000000d-1*amp*o15*o
     &  27*o28 + 2.00000000000000d0*amp*etagrd(i)*eta0*o21*o28*o30 + amp*o13*o
     &  21*o28*o30 + amp*o18*o21*o28*o30 - 2.00000000000000d0*amp*etagrd(i)*et
     &  a0*o27*o28*o30 + amp*o13*o27*o28*o30 + amp*o18*o27*o28*o30 + 1.2
     &  5000000000000d-1*o32 - 2.00000000000000d0*o7
        Ce(i,j) = o7
        Rhs(i,j) = -2.50000000000000d-1*o34 + 2.50000000000000d-1*o10*o3
     &  4 + 5.0000000000000d-1*amp*n*o12*o21*o23*o34 - 5.0000000000000d-
     &  1*amp*o12*o21*o23*o24*o34 + 5.0000000000000d-1*amp*n*o12*o23*o27
     &  *o34 - 5.0000000000000d-1*amp*o12*o23*o24*o27*o34 + 5.0000000000
     &  000d-1*amp*n*o21*o28*o34 + amp*o15*o21*o28*o34 + 5.0000000000000
     &  d-1*amp*n*o27*o28*o34 + amp*o15*o27*o28*o34 - 4.0000000000000d0*
     &  amp*etagrd(i)*eta0*o21*o28*o30*o34 - 2.00000000000000d0*amp*o13*o21*o2
     &  8*o30*o34 - 2.00000000000000d0*amp*o18*o21*o28*o30*o34 + 4.00000
     &  00000000d0*amp*etagrd(i)*eta0*o27*o28*o30*o34 - 2.00000000000000d0*amp
     &  *o13*o27*o28*o30*o34 - 2.00000000000000d0*amp*o18*o27*o28*o30*o3
     &  4 - 2.50000000000000d-1*o32*o34


```

bhbrill.m:
```
$Path = Union[$Path,{"~/SetTensor"}];
Needs["SetTensor`"];

Dimension = 3;
x[1] = eta; x[2] = q; x[3] = phi;
qf[eta_,q_] := amp (Exp[-(eta-eta0)^2/sigma^2]+Exp[-(eta+eta0)^2/sigma^2]) Sin[q]^n

md = {
{Exp[2 qf[eta,q]],0,0},
{0,Exp[2 qf[eta,q]],0},
{0,0,Sin[q]^2}} psi2d[eta,q]^4;
InitializeMetric[md];

Clear[exc];
DefineTensor[exc];
SetTensor[exc[la,lb],{{0,0,0},{0,0,0},{0,0,0}}];

tmp = RicciR[la,lb] Metricg[ua,ub]+exc[la,lb] Metricg[ua,ub] exc[lc,ld] Metricg[uc,ud]-
  exc[la,lb] exc[lc,ld] Metricg[ua,uc] Metricg[ub,ud];
tmp = RicciToAffine[tmp];
tmp = EvalMT[tmp];
tmp = ExpandAll[-Exp[2 qf[eta,q]] psi2d[eta,q]^5/8 tmp]
sav=tmp
tmp = SubFun[sav,psi2d[eta,q],2 Cosh[eta/2]+psi2d[eta,q]]

(* Make the stencil... *)

stencil = ExpandAll[tmp /. {
 D[psi2d[eta,q],eta]->(psi2d[i+1,j]-psi2d[i-1,j])/(2 deta),
 D[psi2d[eta,q],eta,eta]->(psi2d[i+1,j]+psi2d[i-1,j]-2 psi2d[i,j])/(deta deta),
 D[psi2d[eta,q],q]->(psi2d[i,j+1]-psi2d[i,j-1])/(2 dq),
 D[psi2d[eta,q],q,q]->(psi2d[i,j+1]+psi2d[i,j-1]-2 psi2d[i,j])/(dq dq),
 psi2d[eta,q]->psi2d[i,j]
 }];

cn = Coefficient[stencil,psi2d[i,j+1]]
cs = Coefficient[stencil,psi2d[i,j-1]]
ce = Coefficient[stencil,psi2d[i+1,j]]
cw = Coefficient[stencil,psi2d[i-1,j]]
cc = Coefficient[stencil,psi2d[i,j]]
rhs = -SubFun[tmp,psi2d[eta,q],0]

FortranOutputOfDepList = "(i,j)";
$FortranReplace = Union[{
      "UND"->"_",
      "(eta,q)"->"(i,j)"
}];
fd = FortranOpen["bhbrill.x"];
FortranWrite[fd,Cn[i,j],cn ];
FortranWrite[fd,Cs[i,j],cs ];
FortranWrite[fd,Cw[i,j],cw ];
FortranWrite[fd,Cc[i,j],cc ];
FortranWrite[fd,Ce[i,j],ce ];
FortranWrite[fd,Rhs[i,j],rhs ];
FortranClose[fd];

(* Next part, write out conformal g's and d's *)


xv = Exp[eta] Sin[q] Cos[phi];
yv = Exp[eta] Sin[q] Sin[phi];
zv = Exp[eta] Cos[q];

mc = Table[ D[ {xv,yv,zv}[[i]], {eta,q,phi}[[j]] ],{i,1,3},{j,1,3}];
mci = Simplify[Inverse[mc]];

Clear[mct];
DefineTensor[mct,{{1,2},1}];
Iter[mct[ua,lb],
  mct[ua,lb]=mc[[ua,-lb]];
];

Clear[mcti];
DefineTensor[mcti,{{1,2},1}];
Iter[mcti[ua,lb],
  mcti[ua,lb]=mci[[ua,-lb]];
];

gijtmp = Exp[2 eta]/psi2d[eta,q]^4 Metricg[lc,ld] mcti[uc,la] mcti[ud,lb]

Clear[i2];
DefineTensor[i2,{{2,1},1}];

fd = FortranOpen["gij.x"];
Iter[i2[ua,ub],
  v1 = {x,y,z}[[ua]];
  v2 = {x,y,z}[[ub]];
  metv = ToExpression["g"<>ToString[v1]<>ToString[v2]<>"[i,j,k]"];
  gg[v1,v2]=Simplify[EvalMT[gijtmp,{la->-ua,lb->-ub}]];
  FortranWrite[fd,metv,gg[v1,v2]];
  For[ii=1,ii<=3,ii++,
    v3 = {x,y,z}[[ii]];
    dmetv = ToExpression["d"<>ToString[v3]<>ToString[metv]];
    res = OD[gg[v1,v2],lc] mcti[uc,ld]/2;
    res = EvalMT[res,ld-> -ii];
    res = Simplify[res];
    FortranWrite[fd,dmetv,res];
  ];
];
FortranClose[fd];

$FortranReplace = {
  "UND"->"_",
  "(eta,q)"->""
};

fd = FortranOpen["psi_1st_deriv.x"];
For[ii=1,ii<=3,ii++,
  v1 = {x,y,z}[[ii]];
  psv =ToExpression["psi"<>ToString[v1]<>"[i,j,k]"];
  rhs = CD[Exp[-eta/2] psi2dv[eta,q],lc] mcti[uc,la];
  rhs = EvalMT[rhs,{la->-ii}]/(Exp[-eta/2] psi2dv[eta,q]);
  FortranWrite[fd,psv,rhs];
];
FortranClose[fd];

fd = FortranOpen["psi_2nd_deriv.x"];
Iter[i2[ua,ub],
  v1 = {x,y,z}[[ua]];
  v2 = {x,y,z}[[ub]];
  psv = ToExpression["psi"<>ToString[v1]<>ToString[v2]<>"[i,j,k]"];
  rhs = OD[OD[Exp[-eta/2] psi2dv[eta,q],lc] mcti[uc,la],ld] mcti[ud,lb];
  rhs = EvalMT[rhs,{la->-ua,lb->-ub}]/(Exp[-eta/2] psi2dv[eta,q]);
  FortranWrite[fd,psv,rhs];
];
FortranClose[fd];

```


combined_doc_context: ## README (README):
```
Cactus Code Thorn IDAxiBrillBH
Author(s)    : Steve Brandt
               Paul Walker
               Ryoji Takahashi
Maintainer(s): Cactus team
Licence      : LGPL
--------------------------------------------------------------------------

1. Purpose

This thorn calculates initial data for a black hole distorted by an
even parity perturbation.

```

## Documentation (.tex files):
Files: documentation.tex

```tex
=== documentation.tex ===
\documentclass{article}

% Use the Cactus ThornGuide style file
% (Automatically used from Cactus distribution, if you have a 
%  thorn without the Cactus Flesh download this from the Cactus
%  homepage at www.cactuscode.org)
\usepackage{../../../../doc/latex/cactus}

\begin{document}

\title{IDAxiBrillBH}
\author{Paul Walker, Steve Brandt,\\some cleanups by Jonathan Thornburg}
\date{$ $Date$ $}

\maketitle

% Do not delete next line
% START CACTUS THORNGUIDE

% Add all definitions used in this documentation here
%   \def\mydef etc

\def\thorn#1{\textbf{#1}}
\def\arrangement#1{\textbf{#1}}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\begin{abstract}
  Thorn \thorn{IDAxiBrillBH} provides analytic initial data for a vacuum
  black hole spacetime:  a single Schwarzschild black hole in
  isotropic coordinates plus Brill wave.  This initial data is
  provided for \thorn{ADMBase} 3-metric and extrinsic curvature,
  and optionally also for the \thorn{StaticConformal} conformal
  factor and its 1st and 2nd~spatial derivatives.
\end{abstract}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Purpose}

The pioneer, Bernstein, studied a single black hole which is
non-rotating and distorted in azimuthal line symmetry of 2 dimensional 
case \cite{Bernstein93a}. In this non-rotating case, one chooses the
condition, $K_{ij} = 0$,  and 
\begin{equation}
\gamma_{ab} = \psi^4 \hat \gamma_{ab},
\end{equation}
where $\gamma_{ab}$ is the physical three metric and
$\hat{\gamma}_{ab}$ is some chosen conformal three metric.

The Hamiltonian constraint reduces to
\begin{equation}
\hat \Delta \psi = \frac{1}{8}\psi \hat R,
				\label{IDAxiBrillBH/eqn:conformal-hamiltonian}
\end{equation}
where $\hat \Delta$ is the covariant Laplacian and $\hat R$ is the
Ricci tensor for the conformal three metric. This form allows
us to choose an arbitrary conformal three metric, and then solve an
elliptic equation for the conformal factor, therefore satisfying the
constraint equations ($K_{ij} = 0$ trivially satisfies the momentum
constraints in vacuum).  This approach was used to create
``Brill waves'' in a spacetime without black holes \cite{Brill59}.
Bernstein extended this to the black hole spacetime.  Using
spherical-polar coordinates, one can write the 3-metric,
\begin{equation}
				\label{IDAxiBrillBH/eqn:sph-coord}
ds^2 = \psi^4 (e^{2q} (dr^2 + r^2 d \theta^2) + r^2 \sin \theta d
\phi^2),
\end{equation}
where $q$ is the Brill ``packet'' which takes some functional form.
Using this ansatz with (\ref{IDAxiBrillBH/eqn:conformal-hamiltonian})
leads to an elliptic equation for $\psi$ which must be solved
numerically. Applying the isometry condition on $\psi$ at a finite
radius, and applying $M/2r$ falloff conditions on $\psi$ at the
outer boundary (the ``Robin'' condition), along with a packet which
obeys the appropriate symmetries (including being invariant under the
isometry operator), will make this solution describe a black hole with
an incident gravitational wave.  The choice of $q=0$ produces the
Schwarzschild solution.   The typical $q$ function used in
axisymmetry, and considered here in the non-rotating case, is 
\begin{equation}
				\label{IDAxiBrillBH/eqn:Q}
q = Q_0 \sin^n \theta \left [ \exp\left(\frac{\eta -
      \eta_0^2}{\sigma^2}\right ) + \exp\left(\frac{\eta +
      \eta_0^2}{\sigma^2}\right ) \right ].
\end{equation}
Note regularity along the axis requires that the exponent $n$ must be
even.  Choosing a logarithmic radial coordinate
\begin{equation}
				\label{IDAxiBrillBH/eta-coord}
\eta = \ln{\frac{2r}{m}}.
\end{equation}
(where $m$ is a scale parameter), one can rewrite
(\ref{IDAxiBrillBH/eqn:sph-coord}) as
\begin{equation}
ds^2 = \psi(\eta)^4 [ e^{2 q} (d \eta^2 +  d\theta^2) +  \sin^2
\theta d\phi^2].
\end{equation}

The scale parameter $m$ is equal to the mass of the Schwarzschild
black hole, if $q=0$.  In this coordinate, the 3-metric is
\begin{equation}
				\label{IDAxiBrillBH/eqn:metric-brill-eta}
ds^2 = \tilde{\psi}^4 (e^{2q} (d\eta^2+d\theta^2)+\sin^2 \theta
d\phi^2),
\end{equation}
and the Schwarzschild solution is 
\begin{equation}
				\label{IDAxiBrillBH/eqn:psi}
\tilde{\psi} = \sqrt{2M} \cosh (\frac{\eta}{2}).
\end{equation}
We also change the notation of $\psi$ for the conformal factor is same 
as $\tilde{\psi}$ \cite{Camarda97a}, for the $\eta$ coordinate has the
factor $r^{1/2}$ in the conformal factor.  Clearly $\psi(\eta)$ and
$\psi$ differ by a factor of $\sqrt{r}$.  The Hamiltonian 
constraint is
\begin{equation}
				\label{IDAxiBrillBH/eqn:ham}
\frac{\partial^2 \tilde{\psi}}{\partial \eta^2} + \frac{\partial^2
  \tilde{\psi}}{\partial \theta^2} + \cot \theta \frac{\partial
  \tilde{\psi}}{\partial \theta} = - \frac{1}{4} \tilde{\psi}
(\frac{\partial^2 q}{\partial \eta^2} + \frac{\partial^2 q}{\partial
  \theta^2} -1).
\end{equation}

For solving this Hamiltonian constraint numerically.  At first
we substitute
\begin{eqnarray}
\delta \tilde{\psi} & = & \tilde{\psi}+\tilde{\psi}_0 \\
                    & = & \tilde{\psi}-\sqrt{2m} \cosh(\frac{\eta}{2}).
\end{eqnarray}
to the equation~(\ref{IDAxiBrillBH/eqn:ham}), then we can linearize it as
\begin{equation}
\frac{\partial^2 \delta\tilde{\psi}}{\partial \eta^2} + \frac{\partial^2
  \delta\tilde{\psi}}{\partial \theta^2} + \cot \theta \frac{\partial
  \delta\tilde{\psi}}{\partial \theta} = - \frac{1}{4}
(\delta\tilde{\psi} + \tilde{\psi}_0) (\frac{\partial^2 q}{\partial
  \eta^2} + \frac{\partial^2 q}{\partial \theta^2} -1).
				\label{IDAxiBrillBH/eqn:ham-linear}
\end{equation}
For the boundary conditions, we use for the inner boundary condition
an isometry condition:
\begin{equation}
\frac{\partial \tilde{\psi}}{\partial \eta}|_{\eta = 0} = 0,
				\label{IDAxiBrillBH/eqn:isometry-inner-BC}
\end{equation}
and outer boundary condition, a Robin condition:
\begin{equation}
(\frac{\partial \tilde{\psi}}{\partial \eta} + \frac{1}{2}
\tilde{\psi})|_{\eta=\eta_{max}} = 0.
\end{equation}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{The Resulting Slice}

This thorn normalizes things so that if there is no perturbation,
it produces a Schwarzschild ($=$ Brill-Lindquist) slice of the $m=2$
Schwarzschild spacetime.%%%
\footnote{%%%
	 This slice has an apparent horizon at a
	 coordinate radius $r=m/2=1$.
	 }%%%
{}  You can't change this mass. :(

In any case (perturbation or not), this thorn also reports an ADM mass
for the slice.  This seems to be pretty reliable.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{2-D Grid and Interpolation Parameters}

This thorn solves equation~(\ref{IDAxiBrillBH/eqn:ham-linear}) on a 2-D
$(\eta,\theta)$ grid.  However, Cactus needs a 3-D grid, typically with
Cartesian coordinates.  Therefore, this thorn \emph{interpolates} $\psi$
and its $(\eta,\theta)$ derivatives to the Cartesian grid.  More precisely,
for each Cactus grid point, this thorn calculates the corresponding
$(\eta,\theta)$ coordinates, and interpolates the 2-D solution to
that point.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\subsection{Size of the 2-D Grid}

Because of the isometry condition~\eqref{IDAxiBrillBH/eqn:isometry-inner-BC},
the 2-D grid need only cover the region $\eta \ge 0$; the code just
takes the absolute value of $\eta$ before interpolating.

The 2-D grid covers the region $|\eta| \in [0,\texttt{etamax}]$,
$\theta \in [0,\pi]$, where the parameter \verb|etamax| defaults to 5.
If any 3-D grid point's $(|\eta|,\theta)$ is outside this 2-D grid,
this thorn will abort with a fatal error message from the interpolator.
In practice, the most common cause of such an out-of-range point is
the 3-D grid having a grid point at, or very near to, the origin.
For example:
\begin{verbatim}
WARNING level 1 in thorn AEILocalInterp processor 0 host ic0087 (line 1007
of /nfs/nethome/pollney/runs/CactusDev/arrangements/AEIThorns/AEILocalInterp/src
/Lagrange-tensor-product/../template.c):
  ->
   CCTK_InterpLocalUniform():
        interpolation point is either outside the grid,
        or inside but too close to the grid boundary!
        0-origin interpolation point number pt=307062 of N_interp_points=614125
        interpolation point (x,y)=(36.1875,0.955317)
        grid x_min(delta_x)x_max = -0.0199336(0.0199336)6.01993
        grid y_min(delta_y)y_max = -0.0290888(0.0581776)3.17068

WARNING level 0 in thorn IDAxiBrillBH processor 0 host ic0087
  (line 484 of IDAxiBrillBH.F):
  -> error in interpolator: ierror=   -1002
\end{verbatim}

Here the 3-D grid had a point right at the origin
(which by virtue of~\eqref{IDAxiBrillBH/eta-coord} would have given
$\eta = -\infty$), but some software moved the grid point by $10^{-16}m$
or so (the standard Cactus work-around to try to avoid divisions by zero),
giving $\eta \equiv \ln (2 \,{\times}\, 10^{-16}) \approx -36$.
The absolute value of this is the ``$x$'' coordinate the
interpolator is complaining about.

In an ideal world, someone would enhance \thorn{IDAxiBrillBH} so it
could handle a grid point at (or very near to) the origin.%%%
\footnote{%%%
	 See the file \texttt{doc/TODO} in the \thorn{IDAxiBrillBH}
	 source code for some ideas on how this might be done.
	 }%%%
{}  However, so far noone has volunteered to do this.

In the meantime, a staggered grid is the ``standard'' work-around
for this problem.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\subsection{Resolution of the 2-D Grid}

The parameters \verb|neta| and \verb|nq| specify the resolution of
this thorn's 2-D grid in $\eta$ and $\theta$ respectively.%%%
\footnote{%%%
	 Internally, this thorn uses ``$q$'' to refer
	 to $\theta$ in Fortran code, with the $q$ function
	 of~$(\protect\ref{IDAxiBrillBH/eqn:Q})$ being hidden
	 in the Mathematica files (and not present in the Fortran
	 code).  Noone seems to know \emph{why} the code does
	 things this way\dots{}  Unfortunately, this renaming
	 has leaked out into the parameter names\dots
	 }%%%
{}  The default values are a reasonable starting point, but you may
need to increase them substantially if you need very high accuracy
(very small constraint violations).

To help judge what resolution may be needed, this thorn has an option
to write out $\psi(\eta)$ and $\psi$ on the 2-D grid to an ASCII data file
where it can be examined and/or plotted.  To do this, set the Boolean
parameter \verb|output_psi2D|, and possibly also the string parameter
\verb|output_psi2D_file_name|.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\subsection{Interpolation Parameters}

This thorn uses the standard Cactus \verb|CCTK_InterpLocalUniform()|
local interpolation system for this interpolation.  The interpolation
operator is specified with the \verb|interpolator_name| parameter
(this defaults to \verb|"uniform cartesian"|, the interpolation
operator provided by thorn \textbf{CactusBase/LocalInterp}).

The interpolation order and/or other parameters can be specified
in either of two ways:%%%
\footnote{%%%
	 Notice that, for historical reasons, the
	 interpolation parameter names are a bit
	 inconsistent: \texttt{interpolat\underline{ion}\_order}
	 versus \texttt{interpolat\underline{or}\_name}
	 and \texttt{interpolat\underline{or}\_pars}.
	 }%%%
\begin{itemize}
\item	The integer parameter \verb|interpolation_order| may be
	used directly to specify the interpolation order.
\item	More generally, the string parameter \verb|interpolator_pars|
	may be set to any nonempty string (it defaults to the empty string).
	If this is done, this parameter overrides \verb|interpolation_order|,
	and explicitly specifies a parameter string for the interpolator.
\end{itemize}
Note that the default interpolator parameters specify \emph{linear}
interpolation.  This is rather inaccurate, and (due to aliasing effects
between the 2-D and 3-D grids) will give a fair bit of noise in the
metric components.  You may want to specify a higher-order interpolator
to reduce this noise.

For example, for one test series where I (JT) needed very accurate
initial data (I wanted the initial-data errors to be much less than
the errors from 4th~order finite differencing on the 3-D Cactus grid),
I had to use a resolution of $1000$ in $\eta$ and $2000$ in $\theta$,
together with either 4th~order Lagrange or 3rd~order Hermite interpolation
(provided by thorn \textbf{AEIThorns/AEILocalInterp}) to get sufficient
accuracy.

One problem with such high resolutions is that \thorn{IDAxiBrillBH}
uses an internal multigrid solver which allocates local arrays on the
stack, whose size depends on the $\eta$ and $\theta$ resolutions.
For high resolutions these arrays may exceed system- and/or shell-imposed
limits on the maximum stack size, causing the code to crash (core-dump).
In an ideal world, someone would fix the offending code to allocate
large arrays on the heap.  Unless/until that happens, you can either
use lower resolution :(, or try raising the operating-system and/or
shell stack-size limits.
For example, using \verb|tcsh| the shell command \verb|limit|
shows the current limits, and \verb|limit stacksize unlimited|
raises your limit to as much as the operating system will allow.
Using \verb|bash| the corresponding commands are \verb|ulimit -a|
and \verb|ulimit -s unlimited|.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Physical or Conformal Metric}

By default, \thorn{IDAxiBrillBH} generates initial data which uses
a nontrivial static conformal factor (as defined by thorn
\thorn{StaticConformal}).  This initial data includes both the
conformal factor and its 1st and 2nd~spatial derivatives,
so \thorn{IDAxiBrillBH} sets \verb|conformal_state| to 3.

However, if the Boolean parameter \verb|generate_StaticConformal_metric|
is set to \verb|false|, then \thorn{IDAxiBrillBH} generates a pure
physical 3-metric (and sets \verb|conformal_state| to 0).  This is
useful if you have other thorns which don't grok a conformal metric.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\section{Debugging Parameters}

This thorn has options to print very detailed debugging information
about internal quantities at selected grid points.  This is enabled
by setting the integer parameter \verb|debug| to a positive value
(the default is $0$, which means no debugging output).  See
\verb|param.ccl| and the source code \verb|src/IDAxiBrillBH.F| for details.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

\bibliographystyle{prsty}
\begin{thebibliography}{10}
\bibitem{Bernstein93a}
  D. Bernstein, Ph.D thesis University of Illinois Urbana-Champaign,
  (1993)
\bibitem{Brill59}
  D. S. Brill,Ann. Phys.{\bf 7}, 466 (1959)
\bibitem{Camarda97a}
  K. Camarda, Ph.D thesis University of Illinois Urbana-Champaign, (1998)
\end{thebibliography}

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Do not delete next line
% END CACTUS THORNGUIDE

\end{document}

```



Reference answer:
src_code:         o1 = 5.0000000000000d-1*eta(i,j,k)
        o2 = exp(o1)
        o3 = psi2dv(i,j,k)
        o4 = 1/o3
        o5 = cos(phi(i,j,k))
        o6 = cos(q(i,j,k))
        o7 = dqpsi2dv(i,j,k)
        o8 = -1.50000000000000d0*eta(i,j,k)
        o9 = exp(o8)
        o10 = detapsi2dv(i,j,k)
        o11 = sin(q(i,j,k))
        o12 = sin(phi(i,j,k))
        psix(i,j,k) = o2*o4*(o10*o11*o5*o9 - 5.0000000000000d-1*o11*o3*o
     &  5*o9 + o5*o6*o7*o9)
        psiy(i,j,k) = o2*o4*(o10*o11*o12*o9 - 5.0000000000000d-1*o11*o12
     &  *o3*o9 + o12*o6*o7*o9)
        psiz(i,j,k) = o2*o4*(o10*o6*o9 - 5.0000000000000d-1*o3*o6*o9 - o
     &  11*o7*o9)