Task: Implement AHFinder_calcsigma.F for EinsteinAnalysis/AHFinder thorn

thorn_name: EinsteinAnalysis/AHFinder
src_filename: AHFinder_calcsigma.F
interface: # Interface definition for thorn AHFinder
# $Header$


implements: AHFinder
inherits: ADMBase StaticConformal SpaceMask Grid IO ADMMacros

SUBROUTINE SetDriftCorrectPosition ( CCTK_POINTER_TO_CONST IN GH_Pointer, \
                                     CCTK_REAL IN x, \
                                     CCTK_REAL IN y, \
                                     CCTK_REAL IN z )

USES FUNCTION SetDriftCorrectPosition

SUBROUTINE 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

SUBROUTINE PhysToConfInPlace (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 PhysToConfInPlace

################################
###   PUBLIC GRID FUNCTIONS  ###
################################

public:

real ahfindergrid type=GF
{
ahfgrid
} "Horizon function"

real ahfinderexp type=GF
{
ahf_exp
} "Expansion"

real ahfmask type=GF
{
ahmask
} "Grid function for masking"


######################################
###   PUBLIC SCALARS FOR EXCISION  ###
######################################

real hole1_bounds type=SCALAR
{
dhole1_xmin,
dhole1_ymin,
dhole1_zmin,
dhole1_xmax,
dhole1_ymax,
dhole1_zmax
} "Bounds of excision box for hole 1"

real hole2_bounds type=SCALAR
{
dhole2_xmin,
dhole2_ymin,
dhole2_zmin,
dhole2_xmax,
dhole2_ymax,
dhole2_zmax
} "Bounds of excision box for hole 2"

real hole3_bounds type=SCALAR
{
dhole3_xmin,
dhole3_ymin,
dhole3_zmin,
dhole3_xmax,
dhole3_ymax,
dhole3_zmax
} "Bounds of excision box for hole 3"


###################
###   PRIVATE   ###
###################

private:

int triggergroup type=SCALAR
{
triggervar
} "For triggering output"

real ahfgradient type=GF
{
ahfgradx,
ahfgrady,
ahfgradz,
ahfgradn
} "Grid functions for gradients"

real ahfinder_gauss type=GF
{
ahfgauss
} "Grid function for gaussian curvature calculation"

real find3grid type=GF
{
ahfgrid3,
ahf_exp3
} "Grid functions to use in find3 algorithm"

real ahf_centroid type=SCALAR
{
  ahf_centroid_x,
  ahf_centroid_y,
  ahf_centroid_z
} "Centroid of one of the horizons"

int drift_check type=SCALAR
{
  drift_first
} "For checking if its the first drift correction"

#######################################
###  SCALARS AND ARRAYS FOR OUTPUT  ###
#######################################

REAL out_scalars TYPE=SCALAR
{
  out_mass,
  out_radius,
  out_area,
  out_perimeter,
  out_meridian1,
  out_meridian2,
  out_asymx,
  out_asymy,
  out_asymz,
  out_centerx,
  out_centery,
  out_centerz
} "Output of scalar variables"

REAL out_1d_legen TYPE=ARRAY DISTRIB=CONSTANT DIM=1 SIZE=ahf_lmax
{
  out_c0
} "Output of c0 coefficients"

REAL out_2d_legen TYPE=ARRAY DISTRIB=CONSTANT DIM=2 SIZE=ahf_lmax,ahf_lmax
{
  out_cc,out_cs
} "Output of cc and cs coefficients"

REAL ahfinder_gaussian TYPE=ARRAY DISTRIB=CONSTANT DIM=2 SIZE=ahf_ntheta+1,ahf_nphi+1
{
  gaussian
} "Gaussian Curvature"

schedule: # Schedule definitions for thorn AHFinder
#c/*@@
#c  @date    July 1999
#c  @author   Lars Nerger
#c  @@*/


schedule AHFinder_SetSym at CCTK_WRAGH
{
  LANG: Fortran
  OPTIONS: global
} "Set symmetries for AHFinder grid functions"

schedule AHFinder_Startup at CCTK_STARTUP
{
  LANG: C
  OPTIONS: global
} "Register AHFinder as an IO Method"

schedule AHFinder_ParamCheck at PARAMCHECK
{
  LANG: Fortran
  OPTIONS: global
} "Check for physical or conformal metric"

schedule AHFinder_InitOutput at CCTK_INITIAL
{
  LANG: Fortran
} "Create output files, write headers"

if (ahf_active)
{
  STORAGE: hole1_bounds,hole2_bounds,hole3_bounds,ahf_centroid
  STORAGE: out_scalars
  STORAGE: ahfinder_gaussian
  if (ahf_lmax > 0)
  {
    STORAGE: out_1d_legen, out_2d_legen
  }

  if (ahf_persists)
  {
    STORAGE: ahfindergrid,ahfinderexp,ahfgradient,ahfinder_gauss,find3grid
    STORAGE: ahfmask

    schedule ahfinder before driftcorrect at CCTK_ANALYSIS
    {
     LANG: Fortran
     STORAGE: triggergroup
     TRIGGERS: triggergroup
    } "Call apparent horizon finder with persisting grid functions"
  }
  else if (CCTK_Equals (ahf_mask,"off"))
  {
    schedule ahfinder before driftcorrect at CCTK_ANALYSIS
    {
     LANG: Fortran
     STORAGE: ahfindergrid,ahfinderexp,ahfgradient,ahfinder_gauss,find3grid
     STORAGE: ahfmask, triggergroup
     TRIGGERS:triggergroup
    } "Call apparent horizon finder"
  }
  else
  {
    STORAGE: ahfmask
    STORAGE: hole1_bounds,hole2_bounds,hole3_bounds

    schedule ahfinder before driftcorrect at CCTK_ANALYSIS
    {
     LANG: Fortran
     STORAGE: ahfindergrid,ahfinderexp,ahfgradient,ahfinder_gauss,find3grid, triggergroup
     TRIGGERS: triggergroup
    } "Call apparent horizon finder with persisting mask"
  }
}

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


#################################
###   RESTRICTED PARAMETERS   ###
#################################

restricted:

BOOLEAN ahf_active "Activate AHFinder?" STEERABLE = ALWAYS
{
} "no"

BOOLEAN ahf_persists "Do the finder grid functions stay around?"
{
} "no"



##############################
###   PRIVATE PARAMETERS   ###
##############################

private:


############################
### General parameters   ###
############################

BOOLEAN ahf_ReportAlways "Report for all surfaces found (yes) or just for apparent horizons (no)"
{
} "no"

BOOLEAN ahf_find3 "Searching for 3 surfaces?"
{
} "no"

BOOLEAN ahf_trapped_surface "Minimize (expansion + delta) to find trapped surface?" STEERABLE = ALWAYS
{
} "no"

INT ahf_findevery "How often to look for horizons" STEERABLE = ALWAYS
{
1: :: "Set to 1 for searching each iteration"
} 1

INT ahf_findafter "After how many iterations look for horizons" STEERABLE = ALWAYS
{
0: :: "Any positive integer"
} 0

REAL ahf_findaftertime "After how much time look for horizons"
{
0.0: :: "Any positive real number. If non-zero overides ahf_findafter"
} 0.0

REAL trapped_surface_delta "find (expansion = delta) surface" STEERABLE = ALWAYS
{
 : :: "Just a real number"
} 0.0


########################################
### Parameters for surface expansion ###
########################################

BOOLEAN ahf_phi "Expand also in phi? (seach for non-axisymmetric surface)" STEERABLE = ALWAYS
{
} "no"

BOOLEAN ahf_offset "Center offset from origin?"
{
} "no"

BOOLEAN ahf_wander "Allow the center to wander?"
{
} "no"

INT ahf_lmax "Maximum number of terms in theta expansion"
{
0:19 :: "Range from 0 to 19"
} 8

REAL ahf_xc "x-coordinate of center of expansion" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_yc "y-coordinate of center of expansion" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_zc "z-coordinate of center of expansion" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_xc_0 "x-coordinate of center of expansion for first surface with find3" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_yc_0 "y-coordinate of center of expansion for first surface with find3" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_zc_0 "z-coordinate of center of expansion for first surface with find3" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_xc_1 "x-coordinate of center of expansion for second surface with find3" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_yc_1 "y-coordinate of center of expansion for second surface with find3" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_zc_1 "z-coordinate of center of expansion for second surface with find3" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_xc_2 "x-coordinate of center of expansion for third surface with find3" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_yc_2 "y-coordinate of center of expansion for third surface with find3" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_zc_2 "z-coordinate of center of expansion for third surface with find3" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0


########################################
### Parameters for surface integrals ###
########################################

INT ahf_ntheta "Number of subdivisions in theta" STEERABLE = ALWAYS
{
 1: :: "Any sensible integer"
} 100

INT ahf_nphi "Number of subdivisions in phi" STEERABLE = ALWAYS
{
 1: :: "Any sensible integer"
} 100


#########################################
### Parameters to indicate symmetries ###
#########################################

# IMPORTANT: This symmetries refer to the surface itself, and NOT the grid.

# Notice that octant = "yes"  enforces reflection symmetries on all
# three coordinate planes, while  octant = "high"  enforces also the
# extra symmetry of rotation of pi/2 around the z axis.

BOOLEAN ahf_refx "Reflection symmetry x->-x?" STEERABLE = ALWAYS
{
} "no"

BOOLEAN ahf_refy "Reflection symmetry y->-y?" STEERABLE = ALWAYS
{
} "no"

BOOLEAN ahf_refz "Reflection symmetry z->-z?" STEERABLE = ALWAYS
{
} "no"

BOOLEAN ahf_cartoon "Cartoon mode?" STEERABLE = ALWAYS
{
} "no"

KEYWORD ahf_octant "Octant symmetry?" STEERABLE = ALWAYS
{
  "no"   :: "No octant symmetry"
  "yes"  :: "Octant symmetry: reflection symmetry on all three coordinate planes"
  "high" :: "Octant symmetry + symmetry of rotation of pi/2 around z axis"
} "no"


#############################################
### Parameters for minimization algorithm ###
#############################################

BOOLEAN ahf_minarea "Minimize area instead of expansion?"
{
} "no"

INT ahf_maxiter "Maximum number of iterations of POWELL"
{
 : :: "Any sensible integer value"
} 10

REAL ahf_tol "Tolerance for minimization routines"
{
0: :: "A sensible positive number"
} 0.1


####################################
### Parameters for initial guess ###
####################################

BOOLEAN ahf_sloppyguess "Use sphere as initial guess?"
{
} "no"

BOOLEAN ahf_guess_absmin "Use absolute min to start minimization?"
{
} "no"

BOOLEAN ahf_guessold "Use old horizon as initial guess?" STEERABLE = ALWAYS
{
} "no"

BOOLEAN ahf_inner "Look for inner horizon?"
{
} "no"

BOOLEAN ahf_manual_guess "Use specified coefficients for guess?"
{
} "no"

INT ahf_nn0 "Number of subdivisions of c0(0) for initial guess"
{
 : :: "Some positive integer"
} 10

INT ahf_nn2 "Number of subdivisions of c0(2) for initial guess"
{
 : :: "Some positive integer"
} 10

REAL  ahf_l0_guess "Manual guess for l=0 component"
{
 : :: "Anything"
} 1.0

REAL  ahf_l2_guess "Manual guess for l=2 component"
{
 : :: "Anything"
} 0.0

REAL  ahf_l4_guess "Manual guess for l=4 component"
{
 : :: "Anything"
} 0.0

REAL  ahf_l6_guess "Manual guess for l=6 component"
{
 : :: "Anything"
} 0.0

REAL  ahf_l8_guess "Manual guess for l=8 component"
{
 : :: "Anything"
} 0.0

REAL  ahf_l10_guess "Manual guess for l=10 component"
{
 : :: "Anything"
} 0.0

REAL  ahf_l12_guess "Manual guess for l=12 component"
{
 : :: "Anything"
} 0.0

REAL  ahf_l14_guess "Manual guess for l=14 component"
{
 : :: "Anything"
} 0.0

REAL  ahf_l16_guess "Manual guess for l=16 component"
{
 : :: "Anything"
} 0.0

REAL  ahf_l18_guess "Manual guess for l=18 component"
{
 : :: "Anything"
} 0.0

REAL ahf_r0 "Radius of initial sphere (0 forces largest sphere)" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_r0_0 "Radius of first initial sphere for find3 (0 forces largest sphere)" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_r0_1 "Radius of second initial sphere for find3 (0 forces largest sphere)" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0

REAL ahf_r0_2 "Radius of third initial sphere for find3 (0 forces largest sphere)" STEERABLE = ALWAYS
{
 : :: "Anything"
} 0.0



#####################################
### Parameters for flow algorithm ###
#####################################

BOOLEAN ahf_flow "Use flow instead of minimization?"  STEERABLE = ALWAYS
{
} "no"

INT ahf_flowiter "Maximum number of iterations for flow" STEERABLE = ALWAYS
{
0: :: "Anything"
} 200

REAL ahf_flowa "alpha parameter for flow"
{
 : ::  "Anything"
} 0.01

REAL ahf_flowb "beta parameter for flow"
{
 : :: "Anything"
} 0.5

REAL ahf_flowh "Weight of H flow"
{
 : :: "Anything"
} 0.0

REAL ahf_flowc "Weight of C flow"
{
 : :: "Anything"
} 1.0

REAl ahf_flown "Weight of N flow"
{
 : :: "Anything"
} 0.0

REAL ahf_flowtol "Tolerance for flow"
{
 : :: "Anything"
} 0.0001

REAL ahf_maxchange "Maximum relative difference between 1 big and 2 small steps"
{
 : :: "Anything"
} 0.1

REAL ahf_minchange "Minimum relative difference between 1 big and 2 small steps"
{
 : :: "Anything"
} 0.01


######################################
### Parameters related to centroid ###
######################################
INT horizon_to_announce_centroid \
  "For which horizon should we announce the centroid to driftcorrect"
{
  0   :: "don't announce the centroid"
  1:3 :: "announce this horizon's centroid each time we find it"
} 0

INT horizon_to_output_centroid \
  "For which horizon should we output the centroid"
{
  0   :: "don't output any centroids"
  1:3 :: "output this horizon's centroid each time we find it"
} 0

#############################
### Parameters for output ###
#############################

BOOLEAN ahf_logfile "Write log file?"
{
} "no"

BOOLEAN ahf_verbose "Print messages to screen?"
{
} "yes"

BOOLEAN ahf_veryverbose "Print messages at each iteration step to screen?"
{
} "no"

BOOLEAN ahf_guessverbose "Print info on initial guess?"
{
} "no"

BOOLEAN ahf_1Doutput "1D output of grid functions?"
{
} "no"

BOOLEAN ahf_2Doutput "2D output of grid functions?" STEERABLE = ALWAYS
{
} "no"

BOOLEAN ahf_3Doutput "3D output of grid functions?" STEERABLE = ALWAYS
{
} "no"

BOOLEAN ahf_HDF5output "HDF5 output of AHFinder data?" STEERABLE = ALWAYS
{
} "no"

BOOLEAN ahf_areamap "Find area map?"
{
} "no"

BOOLEAN ahf_gaussout "Output gaussian curvature of horizon?" STEERABLE = ALWAYS
{
} "yes"



###########################
### Parameters for mask ###
###########################

KEYWORD ahf_mask "Use mask?" STEERABLE = ALWAYS
{
"off"    :: "Mask is off"
"strong" :: "Mask set only for definite horizons"
"weak"   :: "Mask set for both definite and probable horizons"
} "off"

KEYWORD ahf_masktype "Type of mask" STEERABLE = ALWAYS
{
"lego" :: "Mask is a lego sphere"
"cube" :: "Mask is a cube"
"poly" :: "Mask is a polyhedra"
} "cube"

REAL ahf_mask_time "Time after which to start setting the mask"
{
: :: "Anything goes. Negative number means setting the mask as soon as possible"
} -1.0

BOOLEAN ahf_mask_0 "Mask for first horizon with find3?"
{
} "yes"

BOOLEAN ahf_mask_1 "Mask for second horizon with find3?"
{
} "yes"

BOOLEAN ahf_mask_2 "Mask for third horizon with find3?"
{
} "yes"

INT ahf_maskbuffer "Number of grid points in mask buffer zone" STEERABLE = ALWAYS
{
0 :: "Positive please"
} 5

REAL ahf_maskshrink "Shrink factor for mask" STEERABLE = ALWAYS
{
0.0:1.0 :: "Must be positive and not larger than 1"
} 0.8

REAL ahf_shiftcoeff "Coefficient for shift"
{
: :: "Anything goes"
} 0.0

INT interpolation_order "Order for interpolation" STEERABLE = ALWAYS
{
  1:4 :: "Choose between first and fourth order interpolation"
} 2

STRING interpolation_operator "Name of interpolation operator to use" STEERABLE = ALWAYS
{
  ".+" :: "A valid name for a registered interpolation operator"
} "uniform cartesian"

###############################################
###   PARAMETERS SHARED FROM OTHER THORNS   ###
###############################################


###############
### FROM IO ###
###############

shares: IO

USES STRING out_dir


#################
### FROM GRID ###
#################

shares: grid

USES KEYWORD domain
USES KEYWORD quadrant_direction
USES KEYWORD bitant_plane


####################
### FROM ADMBase ###
####################

shares: admbase

USES KEYWORD metric_type

######################
### FROM ADMMacros ###
######################

shares: ADMMacros

USES INT spatial_order

######################
### FROM SpaceMask ###
######################

shares: spacemask

USES BOOLEAN use_mask

configuration: # Configuration definition for thorn CactusEinstein/AHFinder
# $Header$

REQUIRES CartGrid3D

context: AHFinder_shift.F:
```
/*@@
  @file      AHFinder_shift.F
  @date      May 2000
  @author    Miguel Alcubierre
  @desc 
             Set up horizon (area) locking shift.  The area
             locking shift is obtained from the following
             expression:

                 a        __a
             beta   =  b  \/ f


             where f is the "horizon function", and where b is given by:


                         /             ab               2 \
             b  =  alpha | trK   -    K      d f d f / u  |
                         \                    a   b       /

                         / __2      __a__b              2 \
                     /   | \/ f  -  \/ \/ f  d f d f / u  |
                         \                    a   b       /


             with "alpha" the lapse function and:


              2     mn
             u  =  g   d f d f
                        m   n

  @enddesc 
@@*/

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

      subroutine AHFinder_shift(CCTK_ARGUMENTS)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS
      DECLARE_CCTK_FUNCTIONS

      integer i,j,k
      integer order_save

      CCTK_REAL det,idet
      CCTK_REAL gdxx,gdyy,gdzz,gdxy,gdxz,gdyz
      CCTK_REAL guxx,guyy,guzz,guxy,guxz,guyz
      CCTK_REAL kdxx,kdyy,kdzz,kdxy,kdxz,kdyz
      CCTK_REAL ddxxx,ddxyy,ddxzz,ddxxy,ddxxz,ddxyz
      CCTK_REAL ddyxx,ddyyy,ddyzz,ddyxy,ddyxz,ddyyz
      CCTK_REAL ddzxx,ddzyy,ddzzz,ddzxy,ddzxz,ddzyz
      CCTK_REAL dfx,dfy,dfz,dfux,dfuy,dfuz
      CCTK_REAL d2fxx,d2fyy,d2fzz,d2fxy,d2fxz,d2fyz
      CCTK_REAL c2fxx,c2fyy,c2fzz,c2fxy,c2fxz,c2fyz
      CCTK_REAL idx,idy,idz,idx2,idy2,idz2,idxy,idxz,idyz
      CCTK_REAL zero,half,one,two
      CCTK_REAL aux,T0,T1,T2,T3,T4,T5

      CCTK_REAL, DIMENSION(nx,ny,nz) :: mask,betax_old,betay_old,betaz_old


!     *******************
!     ***   NUMBERS   ***
!     *******************

      zero = 0.0D0
      half = 0.5D0
      one  = 1.0D0
      two  = 2.0D0


!     *********************************
!     ***   SAY WHAT WE ARE DOING   ***
!     *********************************

      write(*,*)
      write(*,*) 'AHFinder: Setting up horizon locking shift.'
      write(*,*)

      betax_old = betax
      betay_old = betay
      betaz_old = betaz


!     *******************************
!     ***   SET UP SHIFT VECTOR   ***
!     *******************************

      idx = half/dx
      idy = half/dy
      idz = half/dz

      idxy = idx*idy
      idxz = idx*idz
      idyz = idy*idz

      idx2 = one/dx**2
      idy2 = one/dy**2
      idz2 = one/dz**2

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

!              Find spatial metric.

               gdxx = gxx(i,j,k)
               gdyy = gyy(i,j,k)
               gdzz = gzz(i,j,k)
               gdxy = gxy(i,j,k)
               gdxz = gxz(i,j,k)
               gdyz = gyz(i,j,k)

!              Find extrinsic curvature.

               kdxx = kxx(i,j,k)
               kdyy = kyy(i,j,k)
               kdzz = kzz(i,j,k)
               kdxy = kxy(i,j,k)
               kdxz = kxz(i,j,k)
               kdyz = kyz(i,j,k)

!              Find determinant of spatial metric.

               det = gdxx*gdyy*gdzz + two*gdxy*gdxz*gdyz
     .             - gdxx*gdyz**2 - gdyy*gdxz**2 - gdzz*gdxy**2

               idet = one/det

!              Find inverse spatial metric.

               guxx = idet*(gdyy*gdzz - gdyz**2)
               guyy = idet*(gdxx*gdzz - gdxz**2)
               guzz = idet*(gdxx*gdyy - gdxy**2)

               guxy = idet*(gdxz*gdyz - gdzz*gdxy)
               guxz = idet*(gdxy*gdyz - gdyy*gdxz)
               guyz = idet*(gdxy*gdxz - gdxx*gdyz)

!              Find first spatial derivatives of f.

               dfx = idx*(ahfgrid(i+1,j,k) - ahfgrid(i-1,j,k))
               dfy = idy*(ahfgrid(i,j+1,k) - ahfgrid(i,j-1,k))
               dfz = idz*(ahfgrid(i,j,k+1) - ahfgrid(i,j,k-1))

!              Raise indices in first derivatives.

               dfux = guxx*dfx + guxy*dfy + guxz*dfz
               dfuy = guxy*dfx + guyy*dfy + guyz*dfz
               dfuz = guxz*dfx + guyz*dfy + guzz*dfz

!              Find derivatives of metric using finite differences.

               ddxxx = idx*(gxx(i+1,j,k) - gxx(i-1,j,k))
               ddxyy = idx*(gyy(i+1,j,k) - gyy(i-1,j,k))
               ddxzz = idx*(gzz(i+1,j,k) - gzz(i-1,j,k))
               ddxxy = idx*(gxy(i+1,j,k) - gxy(i-1,j,k))
               ddxxz = idx*(gxz(i+1,j,k) - gxz(i-1,j,k))
               ddxyz = idx*(gyz(i+1,j,k) - gyz(i-1,j,k))

               ddyxx = idy*(gxx(i,j+1,k) - gxx(i,j-1,k))
               ddyyy = idy*(gyy(i,j+1,k) - gyy(i,j-1,k))
               ddyzz = idy*(gzz(i,j+1,k) - gzz(i,j-1,k))
               ddyxy = idy*(gxy(i,j+1,k) - gxy(i,j-1,k))
               ddyxz = idy*(gxz(i,j+1,k) - gxz(i,j-1,k))
               ddyyz = idy*(gyz(i,j+1,k) - gyz(i,j-1,k))

               ddzxx = idz*(gxx(i,j,k+1) - gxx(i,j,k-1))
               ddzyy = idz*(gyy(i,j,k+1) - gyy(i,j,k-1))
               ddzzz = idz*(gzz(i,j,k+1) - gzz(i,j,k-1))
               ddzxy = idz*(gxy(i,j,k+1) - gxy(i,j,k-1))
               ddzxz = idz*(gxz(i,j,k+1) - gxz(i,j,k-1))
               ddzyz = idz*(gyz(i,j,k+1) - gyz(i,j,k-1))

!              Find second spatial derivatives of f.

               d2fxx = (ahfgrid(i+1,j,k) - two*ahfgrid(i,j,k)
     .               +  ahfgrid(i-1,j,k))*idx2
               d2fyy = (ahfgrid(i,j+1,k) - two*ahfgrid(i,j,k)
     .               +  ahfgrid(i,j-1,k))*idy2
               d2fzz = (ahfgrid(i,j,k+1) - two*ahfgrid(i,j,k)
     .               +  ahfgrid(i,j,k-1))*idz2

               d2fxy = (ahfgrid(i+1,j+1,k) + ahfgrid(i-1,j-1,k)
     .               -  ahfgrid(i+1,j-1,k) - ahfgrid(i-1,j+1,k))*idxy
               d2fxz = (ahfgrid(i+1,j,k+1) + ahfgrid(i-1,j,k-1)
     .               -  ahfgrid(i+1,j,k-1) - ahfgrid(i-1,j,k+1))*idxz
               d2fyz = (ahfgrid(i,j+1,k+1) + ahfgrid(i,j-1,k-1)
     .               -  ahfgrid(i,j+1,k-1) - ahfgrid(i,j-1,k+1))*idyz

!              Find second covariant derivatives of f.

               c2fxx = d2fxx - half*(dfux*ddxxx
     .               + dfuy*(two*ddxxy - ddyxx)
     .               + dfuz*(two*ddxxz - ddzxx))

               c2fyy = d2fyy - half*(dfuy*ddyyy
     .               + dfux*(two*ddyxy - ddxyy)
     .               + dfuz*(two*ddyyz - ddzyy))

               c2fzz = d2fzz - half*(dfuz*ddzzz
     .               + dfux*(two*ddzxz - ddxzz)
     .               + dfuy*(two*ddzyz - ddyzz))

               c2fxy = d2fxy - half*(dfux*ddyxx + dfuy*ddxyy
     .               + dfuz*(ddxyz + ddyxz - ddzxy))

               c2fxz = d2fxz - half*(dfux*ddzxx + dfuz*ddxzz
     .               + dfuy*(ddxyz + ddzxy - ddyxz))

               c2fyz = d2fyz - half*(dfuy*ddzyy + dfuz*ddyzz
     .               + dfux*(ddyxz + ddzxy - ddxyz))

!                                 2    /  m      \ - 1
!              Find:   T0 =  1 / u  =  | d f d f |
!                                      \      m  /

               T0 = dfx*dfux + dfy*dfuy + dfz*dfuz

               if (T0.gt.zero) then
                  T0 = one/T0
               else
                  betax(i,j,k) = zero
                  betay(i,j,k) = zero
                  betaz(i,j,k) = zero
                  goto 10
               end if

!                            __2
!              Find:  T1  =  \/ f
 
               T1 = guxx*c2fxx + guyy*c2fyy + guzz*c2fzz
     .            + two*(guxy*c2fxy + guxz*c2fxz + guyz*c2fyz)

!                            __ __     a   b     2
!              Find:  T2  =  \/ \/ f  d f d f / u
!                              a  b 

               T2 = c2fxx*dfux**2 + c2fyy*dfuy**2 + c2fzz*dfuz**2
     .            + two*(c2fxy*dfux*dfuy + c2fxz*dfux*dfuz
     .            + c2fyz*dfuy*dfuz)

               T2 = T2*T0

!              Find:  T3  =  trK

               T3 = guxx*kdxx + guyy*kdyy + guzz*kdzz
     .            + two*(guxy*kdxy + guxz*kdxz + guyz*kdyz)

!                                 a   b     2
!              Find:  T4  =  K   d f d f / u
!                             ab

               T4 = kdxx*dfux**2 + kdyy*dfuy**2 + kdzz*dfuz**2
     .            + two*(kdxy*dfux*dfuy + kdxz*dfux*dfuz
     .            + kdyz*dfuy*dfuz)

               T4 = T4*T0

!              Find shift.

               aux = alp(i,j,k)*(T3 - T4)/(T1 - T2)

               betax(i,j,k) = aux*dfux
               betay(i,j,k) = aux*dfuy
               betaz(i,j,k) = aux*dfuz

 10            continue

            end do
         end do
      end do

!     Boundaries.

      if (CCTK_EQUALS(ahf_shiftbound,'extrap')) then

!        X direction.

         betax(1,:,:) = two*betax(2,:,:) - betax(3,:,:)
         betay(1,:,:) = two*betay(2,:,:) - betay(3,:,:)
         betaz(1,:,:) = two*betaz(2,:,:) - betaz(3,:,:)

         betax(nx,:,:) = two*betax(nx-1,:,:) - betax(nx-2,:,:)
         betay(nx,:,:) = two*betay(nx-1,:,:) - betay(nx-2,:,:)
         betaz(nx,:,:) = two*betaz(nx-1,:,:) - betaz(nx-2,:,:)

!        Y direction.

         betax(:,1,:) = two*betax(:,2,:) - betax(:,3,:)
         betay(:,1,:) = two*betay(:,2,:) - betay(:,3,:)
         betaz(:,1,:) = two*betaz(:,2,:) - betaz(:,3,:)

         betax(:,ny,:) = two*betax(:,ny-1,:) - betax(:,ny-2,:)
         betay(:,ny,:) = two*betay(:,ny-1,:) - betay(:,ny-2,:)
         betaz(:,ny,:) = two*betaz(:,ny-1,:) - betaz(:,ny-2,:)

!        Z direction.

         betax(:,:,1) = two*betax(:,:,2) - betax(:,:,3)
         betay(:,:,1) = two*betay(:,:,2) - betay(:,:,3)
         betaz(:,:,1) = two*betaz(:,:,2) - betaz(:,:,3)

         betax(:,:,nz) = two*betax(:,:,nz-1) - betax(:,:,nz-2)
         betay(:,:,nz) = two*betay(:,:,nz-1) - betay(:,:,nz-2)
         betaz(:,:,nz) = two*betaz(:,:,nz-1) - betaz(:,:,nz-2)

      end if


!     ********************
!     ***   EXCISION   ***
!     ********************

      if (ahf_shiftexcise.eq.1) then

#ifdef EXCISION_SIMPLEEXCISION

         order_save = order
         order = 1

         call SimpleExcision(_CCTK_ARGUMENTS,x,y,z,r,mask,
     .      betax,betax_old,zero,one,'extrapolation')
         call SimpleExcision(_CCTK_ARGUMENTS,x,y,z,r,mask,
     .      betay,betay_old,zero,one,'extrapolation')
         call SimpleExcision(_CCTK_ARGUMENTS,x,y,z,r,mask,
     .      betaz,betaz_old,zero,one,'extrapolation')

         order = order_save

#else
         call CCTK_WARN(0,"You have not compiled with SimpleExcision")
#endif

      end if


!     ********************************************
!     ***   APPLY SYMMETRIES AND SYNCHRONIZE   ***
!     ********************************************

      call CartSymGN(ierr,cctkGH,"admbase::shift")
      call CCTK_SyncGroup(ierr,cctkGH,"admbase::shift")


!     ***************
!     ***   END   ***
!     ***************

      end subroutine AHFinder_shift


```

AHFinder_mask.F:
```
/*@@
  @file      AHFinder_mask.F
  @date      November 1998
  @author    Miguel Alcubierre
  @desc 
             Set up horizon mask for black hole excision.
  @enddesc 
@@*/

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

      subroutine AHFinder_mask(CCTK_ARGUMENTS,rhor)

!     Set up the horizon mask.  All this routine does is
!     set up the value of the grid function "ahmask" to zero
!     for points inside the horizon.
!
!     It also finds out the radius of the largest sphere that
!     fits inside the horizon and it centered in (xc,yc,zc).
!     This is useful for simple excision.

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS
      DECLARE_CCTK_FUNCTIONS

      integer i,j,k
      integer reduce_handle

      CCTK_REAL zero,one
      CCTK_REAL rhor,rhortemp
      CCTK_REAL buffer,dd,aux
      CCTK_REAL xa,ya,za

!     Reduction variables
      CCTK_INT, dimension(1) :: input_array_type
      CCTK_POINTER_TO_CONST, dimension(1) :: input_array
      CCTK_POINTER, dimension(1) :: reduction_value


!     *******************
!     ***   NUMBERS   ***
!     *******************

      zero = 0.0D0
      one  = 1.0D0

      if ( (ahf_mask_time .lt. 0.0) .or. (cctk_time .ge. ahf_mask_time) ) then

!       *********************************
!       ***   FIND HORIZON FUNCTION   ***
!       *********************************

        call AHFinder_fun(CCTK_ARGUMENTS)


!       ***********************************
!       ***   FIND BUFFER ZONE FACTOR   ***
!       ***********************************

!       The mask will always be set inside the horizon minus
!       a safety buffer zone.  To find out how big is the buffer
!       zone I check the value of the parameter "ahf_maskshrink".
!       This parameter says by which factor of the monopole term
!       to shrink the mask with respect to the real horizon.

!       Here I use the fact that the function "ahfgrid" is zero
!       at the horizon, and is linear on the monopole term
!       (which measures the overall scale).  What I then do is
!       set up the value of "buffer" to a negative number that
!       roughly measures the desired coordinate distance from
!       the mask to the horizon.  The reason why it is negative
!       is because the horizon function is negative inside the
!       horizon, and I just want to compare its value with the
!       value of "buffer" to decide when a given point is masked.

        buffer = - (one-ahf_maskshrink)*c0(0)

!       Now I make sure that there are at least "ahf_maskbuffer"
!       grid points in the buffer zone. The final buffer zone will
!       be whatever is largest between the number of grid points
!       specified by "ahf_maskbuffer" and the shrink factor
!       specified by "ahf_maskshrink".

        dd  = max(dx,dy,dz)
        aux = ahf_maskbuffer*dd

        if (abs(buffer).lt.aux) buffer = - aux


!       *****************************************
!       ***   FIND RADIUS OF LARGEST SPHERE   ***
!       *****************************************

!       Find the radius of the largest sphere that
!       fits inside the horizon.

        rhor = 1.0D10

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

                 if (ahfgrid(i,j,k).ge.buffer) then
                    aux = sqrt((x(i,j,k)-xc)**2 + (y(i,j,k)-yc)**2
     .                  + (z(i,j,k)-zc)**2)
                    if (rhor.gt.aux) rhor = aux
                 end if

              end do
           end do
        end do

!       Now find the minimum of rhor across processors.

        reduce_handle = -1
        call CCTK_LocalArrayReductionHandle(reduce_handle,"minimum")
        if (reduce_handle.lt.0) then
          call CCTK_WARN(1,"Cannot get handle for minimum reduction ! Forgot to activate an implementation providing reduction operators ??")
        end if

        input_array_type(1)    = CCTK_VARIABLE_INT
        input_array(1)     = CCTK_PointerTo(rhor)
        reduction_value(1) = CCTK_PointerTo(rhortemp)
        call CCTK_ReduceArraysGlobally(ierr, cctkGH, -1,reduce_handle, -1,
     .     1, input_array,0, 0, input_array_type, 1,
     .     input_array_type, reduction_value)
     
        rhor = rhortemp

        if (ierr.ne.0) then
           call CCTK_WARN(1,"AHFinder_mask:Reduction of rhor failed!")
        end if


!       ***********************
!       ***   LEGO SPHERE   ***
!       ***********************

!       If we want a lego shere mask life is simple.
!       Just set the mask inside of horizon (minus a
!       buffer zone) equal to 0.

        if (CCTK_EQUALS(ahf_masktype,'lego')) then
           do k=1,nz
              do j=1,ny
                 do i=1,nx

                    if (ahfgrid(i,j,k).lt.buffer) then
                       ahmask(i,j,k) = zero
                    end if

                 end do
              end do
           end do


!       ************************
!       ***   CUBICAL MASK   ***
!       ************************

!       If we want a cubical mask, set the mask based on the value
!       of rhor.  Notice that if we want the corners of the cube to
!       touch the sphere of radius rhor, we must make the side of
!       the cube equal to rhor/sqrt(3), which is about 0.57*rhor.

        else if (CCTK_EQUALS(ahf_masktype,'cube')) then

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

                    aux = 0.57D0*rhor

                    xa = abs(x(i,j,k)-xc)
                    ya = abs(y(i,j,k)-yc)
                    za = abs(z(i,j,k)-zc)

                    if ((xa.lt.aux).and.(ya.lt.aux).and.(za.lt.aux)) then
                       ahmask(i,j,k) = zero
                    end if

                 end do
              end do
           end do


!       **************************
!       ***   POLYHEDRA MASK   ***
!       **************************

!       Here we want to excise a polyhedra.  But not just any
!       polyhedra, a polyhedra defined by taking a cube and
!       cutting away the corners all the way up to the middle
!       of the edges.  This results in a figure made up of
!       6 squares and 8 equilateral triangles.

!       Notice that for such a figure, if we want the corners
!       to touch a sphere of radius rhor, then the sides have
!       to be rhor/sqrt(2) which is roughly 0.7*rhor.

        else if (CCTK_EQUALS(ahf_masktype,'poly')) then

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

                    aux = 0.7D0*rhor

                    xa = abs(x(i,j,k)-xc)
                    ya = abs(y(i,j,k)-yc)
                    za = abs(z(i,j,k)-zc)

                    if ((xa.lt.aux).and.(ya.lt.aux).and.(za.lt.aux).and.
     .                  ((xa+ya+za).lt.2.0D0*aux)) then
                       ahmask(i,j,k) = zero
                    end if

                 end do
              end do
           end do

        end if


!       *****************************************************
!       ***   APPLY SYMMETRY BOUNDARIES AND SYNCHRONIZE   ***
!       *****************************************************

        call CCTK_SyncGroup(ierr,cctkGH,"ahfinder::ahfmask")
        call CartSymGN(ierr,cctkGH,"ahfinder::ahfmask")

!       If desired, copy ahf_mask to spacemask mask (emask).

        if (use_mask.eq.1) then
           emask = ahmask
        end if


!       ***************
!       ***   END   ***
!       ***************
      end if

      end subroutine AHFinder_mask


```

AHFinder_int.F:
```

/*@@
  @file      AHFinder_int.F
  @date      April 1998
  @author    Miguel Alcubierre
  @desc
             Find surface integrals. The integrals are done
             in parallel, but the number of processors is
             assumed to be either the square of an integer
             or a power of two (if this is not the case,
             I just use less processors).
  @enddesc
  @version   $Header$
@@*/

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

      subroutine AHFinder_int(CCTK_ARGUMENTS)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS
      DECLARE_CCTK_FUNCTIONS

      integer i,j,l,m
      integer npt,npp
      integer l_ntheta,l_nphi,theta0,phi0
      integer npoints
      integer auxi,vindex
      integer ierror

      integer interp_handle,coord_system_handle
      integer reduction_handle,param_table_handle
      character(30) options_string
      character(128) operator
      CCTK_INT red_tmp, nchars

      CCTK_POINTER, dimension(3) :: interp_coords
      CCTK_INT, dimension(9) :: in_array_indices
      CCTK_POINTER, dimension(9) :: out_arrays
      CCTK_INT, dimension(9) :: out_array_type_codes


      CCTK_REAL LEGEN
      CCTK_REAL xp,yp,zp,rp
      CCTK_REAL xw,yw,zw
      CCTK_REAL cost,sint,cosp,sinp
      CCTK_REAL trr,ttt,tpp,trt,trp,ttp,ft,fp
      CCTK_REAL dtheta,dphi,dtp,idtheta,idphi,phistart
      CCTK_REAL det,idet
      CCTK_REAL zero,quarter,half,one,two,three,four,pi
      CCTK_REAL sina,cosa,intw,grad,sigma,h0
      CCTK_REAL theta,phi
      CCTK_REAL aux,aux1,aux2

      CCTK_REAL tempv(0:lmax),tempm(lmax,lmax)

      CCTK_REAL, dimension(3,3) :: gupij

      CCTK_REAL, allocatable, dimension(:) :: costheta,sintheta
      CCTK_REAL, allocatable, dimension(:) :: cosphi,sinphi

      CCTK_REAL, allocatable, dimension(:,:) :: rr,xa,ya,za,da,exp,gradn
      CCTK_REAL, allocatable, dimension(:,:) :: txx,tyy,tzz,txy,txz,tyz
      CCTK_REAL, allocatable, dimension(:,:) :: intmask

!     Reduction variables
      CCTK_POINTER_TO_CONST, dimension(1) :: input_array
      CCTK_POINTER, dimension(1) :: reduction_value
      CCTK_INT, dimension(1) ::input_array_type
      
!     Variables to be saved for next call.

      save dtheta,dphi,dtp,idtheta,idphi,phistart
      save npt,npp,l_ntheta,l_nphi,theta0,phi0

!     Description of variables:
!
!     i,j,l,m    Counters.
!
!     theta      Latitude.
!     phi        Longitude.
!
!     npt        number of processors in theta direction.
!     npp        number of processors in phi direction.
!
!     l_ntheta   Local number of grid points in theta direction.
!     l_nphi     Local number of grid points in phi direction.
!
!     theta0     Local origin in theta direction.
!     phi0       Local origin in phi direction.
!
!     npoints    Number of points to interpolate .
!
!     xp         x coordinate from surface centre.
!     yp         y coordinate from surface centre.
!     zp         z coordinate from surface centre.
!
!     rp         Radius.
!     rr         Radius array.
!
!     xa         Array with x coordinates from grid centre.
!     ya         Array with y coordinates from grid centre.
!     za         Array with z coordinates from grid centre.
!
!     exp        Interpolated expansion.
!
!     txx        Array with interpolated gxx metric component.
!     tyy        Array with interpolated gyy metric component.
!     tzz        Array with interpolated gzz metric component.
!     txy        Array with interpolated gxy metric component.
!     txz        Array with interpolated gxz metric component.
!     tyz        Array with interpolated gyz metric component.
!
!     gradn      Array with interpolated norm of gradient of horizon function.
!
!     intmask    Array with interpolated mask.
!
!     cost       cos(theta)
!     sint       sin(theta)
!     cosp       cos(phi)
!     sinp       sin(phi)
!
!     trr        Metric component {r,r}.
!     ttt        Metric component {theta,theta}.
!     tpp        Metric component {phi,phi}.
!     trt        Metric component {r,theta}.
!     trp        Metric component {r,phi}.
!     ttp        Metric component {theta,phi}.
!
!     ft         dr/dtheta
!     fp         dr/dphi
!
!     dtheta     Grid spacing in theta.
!     dphi       Grid spacing in phi.
!     dtp        dtheta*dphi.
!
!     idtheta    1/(2 dtheta)
!     idphi      1/(2 dphi)
!
!     phistart   Origin for phi (normally 0, but for some symmetries -pi/2).
!
!     da         Area element.


!     *******************
!     ***   NUMBERS   ***
!     *******************

      zero    = 0.0D0
      quarter = 0.25D0
      half    = 0.5D0
      one     = 1.0D0
      two     = 2.0D0
      three   = 3.0D0
      four    = 4.0D0

      pi = acos(-one)


!     *****************************************************************
!     ***   TOTAL NUMBER OF PROCESSORS AND LOCAL PROCESSOR NUMBER   ***
!     *****************************************************************

      myproc = CCTK_MyProc(cctkGH)
      nprocs = CCTK_nProcs(cctkGH)


!     ****************************************
!     ***   GET REDUCTION HANDLE FOR SUM   ***
!     ****************************************

      call CCTK_LocalArrayReductionHandle(reduction_handle,"sum")

      if (reduction_handle.lt.0) then
        call CCTK_WARN(1,"Cannot get handle for sum reduction ! Forgot to activate an implementation providing reduction operators ??")
      end if


!     ******************************************************
!     ***   THINGS TO DO ON FIRST CALL TO THIS ROUTINE   ***
!     ******************************************************

      if (firstint) then

         firstint = .false.


!        ******************************************
!        ***   FIND  phistart,dtheta,dphi,dtp   ***
!        ******************************************

         phistart = zero

         dtheta = pi/dble(ntheta)

         if (cartoon) then

            dphi    = zero
            dtp     = dtheta
            idphi   = one
            idtheta = half/dtheta

         else

            dphi = two*pi/dble(nphi)

            if (refz) dtheta = half*dtheta

            if (refx.and.refy) then
               dphi = quarter*dphi
            else if (refx) then
               dphi = half*dphi
               phistart = - half*pi
            else if (refy) then
               dphi = half*dphi
            end if

            dtp = dtheta*dphi

            idtheta = half/dtheta
            idphi   = half/dphi

         end if


!        *********************************************
!        ***   DIVIDE 2D DOMAIN AMONG PROCESSORS   ***
!        *********************************************

!        For cartoon this is trivial.

         if (cartoon) then

            npt = nprocs
            npp = 1

!        Otherwise it is more complicated.  At the moment I
!        only consider numbers of processors that are either
!        the square of an integer, or a power of two.
!        If neither of this is the case, then I use fewer
!        processors to make sure that I always deal with
!        either a square or a power of two.  This can
!        certainly be improved, but it might not be that
!        urgent since in most cases the number of processors
!        will be a power of two.

         else

            aux = sqrt(dble(nprocs))

!           One processor.

            if (nprocs.eq.1) then

               npt = 1
               npp = 1

!           Square of an integer.

            else if (aux.eq.int(aux)) then

               npt = int(aux)
               npp = int(aux)

!           The number of processors is not the square of an integer.
!           We will now check if it is a power of two.

            else

               l = 1
               m = 1

               i = 1

               do while (l*m.lt.nprocs)

                  npt = l
                  npp = m

                  if (mod(i,2).ne.0) then
                     m = 2*m
                  else
                     l = 2*l
                  end if

                  i = i + 1

               end do

!              "nprocs" is a power of two.

               if (l*m.eq.nprocs) then

                  npt = l
                  npp = m

!              "nprocs" is not a power of two.  This is where I
!              would need to do something clever.  At the moment,
!              I will just use fewer processors.  The number of
!              processors I use is the power of two or the square
!              of an integer that is closest to "nprocs".

               else

                  if (npt*npp.lt.int(aux)**2) then
                     npt = int(aux)
                     npp = int(aux)
                  end if

               end if

            end if

         end if

!        Now be careful not to use too many procs and end up
!        with very few points per proc.

         if (ntheta/npt.lt.3) npt = ntheta/3

         if (.not.cartoon) then
            if (nphi/npp.lt.3) npp = nphi/3
         end if

!        Figure out the number of grid points per processor,
!        and the "origin" for a given processor.

         if (myproc.ge.npt*npp) then

            l_ntheta = 0
            l_nphi   = 0

            theta0 = 0
            phi0   = 0

         else

!           First take the number of grid points per processor
!           in a given direction to be equal to the total number
!           of grid points divided by the number of processors
!           in that direction.

            l_ntheta = ntheta/npt
            l_nphi   = nphi/npp

!           And take the "origin" as the corresponding displacement
!           from the real origin.  Notice that mod(myproc,npt)
!           tells my on which "theta" bin I am, while myproc/npt
!           tells me on which "phi" bin I am.

            i = mod(myproc,npt)
            j = myproc/npt

            theta0 = i*l_ntheta
            phi0   = j*l_nphi

!           Now correct all this if the total number of grid points
!           in a given direction was not exactly divisible by the
!           number of processors on that direction.

            if (l_ntheta*npt.ne.ntheta) then

!              Find residue on theta direction.

               l = ntheta - l_ntheta*npt

!              Distribute residue in first few processors, and
!              displace theta0 accordingly.

               if (i.lt.l) then
                  l_ntheta = l_ntheta + 1
                  theta0 = theta0 + i
               else
                  theta0 = theta0 + l
               end if

            end if

            if (l_nphi*npp.ne.nphi) then

!              Find residue on phi direction.

               l = nphi - l_nphi*npp

!              Distribute residue in first few processors, and
!              displace phi0 accordingly.

               if (j.lt.l) then
                  l_nphi = l_nphi + 1
                  phi0 = phi0 + j
               else
                  phi0 = phi0 + l
               end if

            end if

         end if

      end if


!     **************************************
!     ***   ALLOCATE MEMORY FOR ARRAYS   ***
!     **************************************

      allocate(costheta(1:l_ntheta+1))
      allocate(sintheta(1:l_ntheta+1))

      allocate(cosphi(1:l_nphi+1),sinphi(1:l_nphi+1))

      allocate(rr(1:l_ntheta+1,1:l_nphi+1))

      allocate(xa(1:l_ntheta+1,1:l_nphi+1))
      allocate(ya(1:l_ntheta+1,1:l_nphi+1))
      allocate(za(1:l_ntheta+1,1:l_nphi+1))

      allocate(da(1:l_ntheta+1,1:l_nphi+1))
      allocate(exp(1:l_ntheta+1,1:l_nphi+1))
      allocate(gradn(1:l_ntheta+1,1:l_nphi+1))

      allocate(txx(1:l_ntheta+1,1:l_nphi+1))
      allocate(tyy(1:l_ntheta+1,1:l_nphi+1))
      allocate(tzz(1:l_ntheta+1,1:l_nphi+1))
      allocate(txy(1:l_ntheta+1,1:l_nphi+1))
      allocate(txz(1:l_ntheta+1,1:l_nphi+1))
      allocate(tyz(1:l_ntheta+1,1:l_nphi+1))

      allocate(intmask(1:l_ntheta+1,1:l_nphi+1))


!     ********************************
!     ***   INITIALIZE VARIABLES   ***
!     ********************************

!     Initialize error flags.

      interror1 = 0
      interror2 = 0
      interror3 = 0

!     Initialize surface integrals.

      intexp  = zero
      intexp2 = zero
      intarea = zero
      intexpdel2 = zero

!     For flow algorithm, initialize spectral components.

      if (flow) then

         hflow0 = zero
         hflowc = zero
         hflows = zero

         cflow0 = zero
         cflowc = zero
         cflows = zero

         nflow0 = zero
         nflowc = zero
         nflows = zero

      end if


!     *************************************
!     ***   FIND INTERPOLATING POINTS   ***
!     *************************************

      if (myproc.ge.npt*npp) then

         xa = half*(xmx+xmn)
         ya = half*(ymx+ymn)
         za = half*(zmx+zmn)

      else

         do j=1,l_nphi+1

!           Find phi.

            phi = dphi*dble(j-1+phi0) + phistart

!           Find sines and cosines of phi.

            cosp = cos(phi)
            sinp = sin(phi)

            cosphi(j) = cosp
            sinphi(j) = sinp

            do i=1,l_ntheta+1

!              Find theta.

               theta = dtheta*dble(i-1+theta0)

!              Find sines and cosines of theta.

               cost = cos(theta)
               sint = sin(theta)

               costheta(i) = cost
               sintheta(i) = sint

!              Find radius rp.

               rp = c0(0)

               do l=1+stepz,lmax,1+stepz
                  rp = rp + c0(l)*LEGEN(l,0,cost)
               end do

!              Notice how the sum over m is first.  This will allow
!              me to use the recursion relations to avoid having to
!              start from scratch every time.  Also, I sum over all
!              l even if I do not want some terms.  This is because
!              in order to use the recursion relations I need all
!              polynomials.

               if (nonaxi) then
                  do m=1,lmax
                     aux = dble(m)*phi
                     sina = sin(aux)
                     cosa = cos(aux)
                     do l=m,lmax
                        aux = LEGEN(l,m,cost)
                        rp = rp + aux*cc(l,m)*cosa
                        if (.not.refy) then
                           rp = rp + aux*cs(l,m)*sina
                        end if
                     end do
                  end do
               end if

!              Check for negative radius.

               if (rp.le.zero) then
                  interror1 = 1
               end if

!              Find cartesian coordinates.

               aux = rp*sint

               xp = aux*cosp + xc
               yp = aux*sinp + yc
               zp = rp*cost + zc

!              Save arrays.

               rr(i,j) = rp

               xa(i,j) = xp
               ya(i,j) = yp
               za(i,j) = zp

!              Check if we are within bounds.

               if ((xp.gt.xmx).or.(xp.lt.xmn).or.
     .             (yp.gt.ymx).or.(yp.lt.ymn).or.
     .             (zp.gt.zmx).or.(zp.lt.zmn)) then
                  interror2 = 1
               end if

            end do
         end do

      end if


!     *******************************************
!     ***   REDUCE ERRORS ACROSS PROCESSORS   ***
!     *******************************************

      input_array_type(1) = CCTK_VARIABLE_INT
      reduction_value(1)= CCTK_PointerTo(red_tmp)
      input_array(1)    = CCTK_PointerTo(interror1)
      call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .   1, input_array,0, 0, input_array_type, 1,
     .   input_array_type, reduction_value)
     
      if (ierror.ne.0) then
         call CCTK_WARN(1,"Reduction of norm failed!")
      end if
      interror1 = red_tmp
      
      
      input_array_type(1) = CCTK_VARIABLE_INT
      reduction_value(1)= CCTK_PointerTo(red_tmp)
      input_array(1)    = CCTK_PointerTo(interror2)
      call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .   1, input_array,0, 0, input_array_type, 1,
     .   input_array_type, reduction_value)
     
      if (ierror.ne.0) then
         call CCTK_WARN(1,"Reduction of norm failed!")
      end if
      interror2 = red_tmp

!     If there was an error on any processor then assign
!     large values to the integrals and return from the
!     subroutine (but remember to deallocate the arrays
!     first!).

      interror = .false.

      if ((interror1.ne.0).or.(interror2.ne.0)) then
         intexp  = 1.0D10
         intexp2 = 1.0D10
         intarea = 1.0D10
         intexpdel2 = 1.0D10
         interror = .true.
         goto 10
      end if


!     ***********************
!     ***   INTERPOLATE   ***
!     ***********************

!     Number of points to interpolate.

      npoints = (l_ntheta+1)*(l_nphi+1)

!     parameter, local interpolator, and coordinate system handle.
      param_table_handle = -1
      interp_handle = -1
      coord_system_handle = -1

      options_string = "order = " // char(ichar('0') + interpolation_order)
      call Util_TableCreateFromString (param_table_handle, options_string)
      if (param_table_handle .lt. 0) then
        call CCTK_WARN(0,"Cannot create parameter table for interpolator")
      endif

      call CCTK_FortranString (nchars, interpolation_operator, operator)
      call CCTK_InterpHandle (interp_handle, operator)
      if (interp_handle .lt. 0) then
        call CCTK_WARN(0,"Cannot get handle for interpolation ! Forgot to activate an implementation providing interpolation operators ??")
      endif

      call CCTK_CoordSystemHandle (coord_system_handle, "cart3d")
      if (coord_system_handle .lt. 0) then
        call CCTK_WARN(0,"Cannot get handle for cart3d coordinate system ! Forgot to activate an implementation providing coordinates ??")
      endif

!     fill in the input/output arrays for the interpolator
      interp_coords(1) = CCTK_PointerTo(xa)
      interp_coords(2) = CCTK_PointerTo(ya)
      interp_coords(3) = CCTK_PointerTo(za)

      call CCTK_VarIndex (vindex, "admbase::gxx")
      in_array_indices(1) = vindex
      call CCTK_VarIndex (vindex, "admbase::gyy")
      in_array_indices(2) = vindex
      call CCTK_VarIndex (vindex, "admbase::gzz")
      in_array_indices(3) = vindex
      call CCTK_VarIndex (vindex, "admbase::gxy")
      in_array_indices(4) = vindex
      call CCTK_VarIndex (vindex, "admbase::gxz")
      in_array_indices(5) = vindex
      call CCTK_VarIndex (vindex, "admbase::gyz")
      in_array_indices(6) = vindex
      call CCTK_VarIndex (vindex, "ahfinder::ahf_exp")
      in_array_indices(7) = vindex
      call CCTK_VarIndex (vindex, "ahfinder::ahmask")
      in_array_indices(8) = vindex
      call CCTK_VarIndex (vindex, "ahfinder::ahfgradn")
      in_array_indices(9) = vindex

      out_arrays(1) = CCTK_PointerTo(txx)
      out_arrays(2) = CCTK_PointerTo(tyy)
      out_arrays(3) = CCTK_PointerTo(tzz)
      out_arrays(4) = CCTK_PointerTo(txy)
      out_arrays(5) = CCTK_PointerTo(txz)
      out_arrays(6) = CCTK_PointerTo(tyz)
      out_arrays(7) = CCTK_PointerTo(exp)
      out_arrays(8) = CCTK_PointerTo(intmask)
      out_arrays(9) = CCTK_PointerTo(gradn)

      out_array_type_codes = CCTK_VARIABLE_REAL


!     For minimization we need the interpolated metric,
!     the expansion and the mask.

      if (.not.flow) then

         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     .                               param_table_handle, coord_system_handle,
     .                               npoints, CCTK_VARIABLE_REAL, interp_coords,
     .                               8, in_array_indices,
     .                               8, out_array_type_codes, out_arrays)
      if (ierror < 0) then
        call CCTK_WARN (1, "interpolator call returned an error code");
      endif


!     For N flow, we need the interpolated metric, the expansion,
!     the norm of the gradient of the horizon function, and the mask.

      else if (nw.ne.zero) then

         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     .                               param_table_handle, coord_system_handle,
     .                               npoints, CCTK_VARIABLE_REAL, interp_coords,
     .                               9, in_array_indices,
     .                               9, out_array_type_codes, out_arrays)
         if (ierror < 0) then
           call CCTK_WARN (1, "interpolator call returned an error code");
         endif

!     For H or C flows, we need the interpolated expansion, the
!     norm of the gradient of the horizon function, and the mask.

      else

         call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     .                               param_table_handle, coord_system_handle,
     .                               npoints, CCTK_VARIABLE_REAL, interp_coords,
     .                               3, in_array_indices(7),
     .                               3, out_array_type_codes(7), out_arrays(7))
         if (ierror < 0) then
           call CCTK_WARN (1, "interpolator call returned an error code");
         endif

      end if

!     release parameter table
      call Util_TableDestroy (ierror, param_table_handle)

!     ***************************************
!     ***   CHECK IF WE ARE INSIDE MASK   ***
!     ***************************************

!     Check if we are either inside mask, or to close for comfort.
!     The way I do this is very simple, I just check the interpolated
!     values of the mask.  If any of these values is not 1.0, it means
!     that a point inside the mask is contaminating the interpolation,
!     and this means in turn that we are too close to the mask.

!     Notice that in practice I do not ask for the interpolated values
!     to be exactly 1.0, since round off error can modify the value
!     slightly without really meaning that we are close to the mask.

      if (.not.CCTK_EQUALS(ahf_mask,'off')) then

         if (myproc.lt.npt*npp) then
            do j=1,l_nphi+1
               do i=1,l_ntheta+1
                  if (intmask(i,j).lt.0.99D0) then
                     interror3 = 1
                  end if
               end do
            end do
         end if

         input_array_type(1) = CCTK_VARIABLE_INT
         reduction_value(1)= CCTK_PointerTo(red_tmp)
         input_array(1)    = CCTK_PointerTo(interror3)
         call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .      1, input_array,0, 0, input_array_type, 1,
     .      input_array_type, reduction_value)
     
         interror3 = red_tmp

         if (interror3.ne.0) then
            intexp  = 1.0D10
            intexp2 = 1.0D10
            intarea = 1.0D10
            intexpdel2 = 1.0D10
            interror = .true.
            goto 10
         end if

      end if


!     *************************
!     ***   AREA ELEMENTS   ***
!     *************************

!     Find 2D array for area elements.  Notice that
!     this is not needed for the flow algorithm!

      if (.not.flow) then

         if (myproc.ge.npt*npp) then

            da = zero

         else

            do j=1,l_nphi+1

!              Find sines and cosines of phi.

               cosp = cosphi(j)
               sinp = sinphi(j)

               do i=1,l_ntheta+1

!                 Find {rp}.

                  rp = rr(i,j)

!                 Find sines and cosines of theta.

                  cost = costheta(i)
                  sint = sintheta(i)

!                 Find spherical metric components.

                  trr = sint**2*(txx(i,j)*cosp**2
     .                + tyy(i,j)*sinp**2) + tzz(i,j)*cost**2
     .                + two*sint*(txy(i,j)*sint*cosp*sinp
     .                + cost*(txz(i,j)*cosp + tyz(i,j)*sinp))

                  ttt = rp**2*(cost**2*(txx(i,j)*cosp**2
     .                + tyy(i,j)*sinp**2) + tzz(i,j)*sint**2
     .                + two*cost*(txy(i,j)*cost*cosp*sinp
     .                - sint*(txz(i,j)*cosp + tyz(i,j)*sinp)))

                  tpp = (rp*sint)**2*(txx(i,j)*sinp**2 + tyy(i,j)*cosp**2
     .                - two*txy(i,j)*cosp*sinp)

                  trt = rp*(sint*cost*(txx(i,j)*cosp**2 + tyy(i,j)*sinp**2
     .                - tzz(i,j) + two*txy(i,j)*sinp*cosp)
     .                + (cost**2-sint**2)*(txz(i,j)*cosp + tyz(i,j)*sinp))

                  trp = rp*sint*(sint*(cosp*sinp*(tyy(i,j) - txx(i,j))
     .                + txy(i,j)*(cosp**2 - sinp**2))
     .                + cost*(cosp*tyz(i,j) - sinp*txz(i,j)))

                  ttp = rp**2*sint*(cost*(sinp*cosp*(tyy(i,j) - txx(i,j))
     .                + (cosp**2 - sinp**2)*txy(i,j))
     .                + sint*(sinp*txz(i,j) - cosp*tyz(i,j)))

!                 Find derivatives  {ft,fp}.  For interior points I
!                 use centered differences, and for the boundary points
!                 I use second order one sided differences. Notice that
!                 since this is done even in inter-processor boundaries,
!                 the final result will depend on the number of processors,
!                 but the differences will converge away at high order.

                  if ((i.ne.1).and.(i.ne.l_ntheta+1)) then
                     ft = idtheta*(rr(i+1,j) - rr(i-1,j))
                  else if (i.eq.1) then
                     ft = - idtheta*(three*rr(1,j)
     .                  - four*rr(2,j) + rr(3,j))
                  else
                     ft = + idtheta*(three*rr(l_ntheta+1,j)
     .                  - four*rr(l_ntheta,j) + rr(l_ntheta-1,j))
                  end if

                  if (nonaxi) then
                     if ((j.ne.1).and.(j.ne.l_nphi+1)) then
                        fp = idphi*(rr(i,j+1) - rr(i,j-1))
                     else if (j.eq.1) then
                        fp = - idphi*(three*rr(i,1)
     .                     - four*rr(i,2) + rr(i,3))
                     else
                        fp = + idphi*(three*rr(i,l_nphi+1)
     .                     - four*rr(i,l_nphi) + rr(i,l_nphi-1))
                     end if
                  else
                     fp = zero
                  end if

!                 Find area element.  For this I use the fact that if
!                 we have  r = f(theta,phi), then the area element is:
!
!                        /                  2
!                 da  =  | [ gtt + grr (f,t)  +  2 grt f,t ]
!                        \
!                                      2
!                     [ gpp + grr (f,p)  +  2 grp f,p ]  -  [ gtp
!
!                                                          2 \ 1/2
!                     + grr f,t f,p  +  grt f,p + grp f,t ]  |     dtheta dphi
!                                                            /
!
!                 where  f,t = df/dtheta  and  f,p = df/dphi.

                  aux = (ttt + trr*ft**2 + two*trt*ft)
     .                * (tpp + trr*fp**2 + two*trp*fp)
     .                - (ttp + ft*(trr*fp + trp) + trt*fp)**2

                  if (aux.gt.zero) then
                     aux = sqrt(aux)
                  else
                     aux = zero
                  end if

!                 Multiply with dtheta*dphi.

                  da(i,j) = aux*dtp

               end do
            end do

         end if

      end if


!     *******************************************
!     ***   AREA AND INTEGRALS OF EXPANSION   ***
!     *******************************************

!     To find the integrals I use a second order method:
!     I approximate the value of the integrand at each
!     cell centre by an average of the values at the
!     four cell corners, and then add up all cells.

!     Notice that for the flow algorithm I do not need to
!     calculate the area nor the integrals of the expansion
!     except at the very end, but by then the flag 'flow' has
!     been switched off.

      inside_min_count     = 0
      inside_min_neg_count = 0

      if (.not.flow) then

         if (myproc.lt.npt*npp) then

            do j=1,l_nphi
               do i=1,l_ntheta

                  intarea = intarea + quarter
     .                    *(da(i,j  ) + da(i+1,j  )
     .                    + da(i,j+1) + da(i+1,j+1))

                  intexp  = intexp  + quarter
     .                    *(da(i  ,j  )*exp(i  ,j  )
     .                    + da(i+1,j  )*exp(i+1,j  )
     .                    + da(i  ,j+1)*exp(i  ,j+1)
     .                    + da(i+1,j+1)*exp(i+1,j+1))
                  intexp2 = intexp2 + quarter
     .                    *(da(i  ,j  )*exp(i  ,j  )**2
     .                    + da(i+1,j  )*exp(i+1,j  )**2
     .                    + da(i  ,j+1)*exp(i  ,j+1)**2
     .                    + da(i+1,j+1)*exp(i+1,j+1)**2)

                  intexpdel2 = intexpdel2 + quarter
     .                 *(da(i  ,j  )*(exp(i  ,j  )+trapped_surface_delta)**2
     .                 + da(i+1,j  )*(exp(i+1,j  )+trapped_surface_delta)**2
     .                 + da(i  ,j+1)*(exp(i  ,j+1)+trapped_surface_delta)**2
     .                 + da(i+1,j+1)*(exp(i+1,j+1)+trapped_surface_delta)**2)

                  inside_min_count = inside_min_count + 1

                  if ((exp(i  ,j  ).lt.0.0D0).and.
     .                (exp(i+1,j  ).lt.0.0D0).and.
     .                (exp(i  ,j+1).lt.0.0D0).and.
     .                (exp(i+1,j+1).lt.0.0D0)) then
                     inside_min_neg_count = inside_min_neg_count + 1
                  end if

               end do
            end do

         end if

!        Reduce integrals.

         input_array_type(1) = CCTK_VARIABLE_REAL
         reduction_value(1)= CCTK_PointerTo(aux)
         input_array(1)    = CCTK_PointerTo(intarea)
         call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .      1, input_array,0, 0, input_array_type, 1,
     .      input_array_type, reduction_value)
     
         intarea=aux

         input_array_type(1) = CCTK_VARIABLE_REAL
         reduction_value(1)= CCTK_PointerTo(aux)
         input_array(1)    = CCTK_PointerTo(intexp)
         call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .      1, input_array,0, 0, input_array_type, 1,
     .      input_array_type, reduction_value)
     
         intexp=aux

         input_array_type(1) = CCTK_VARIABLE_REAL
         reduction_value(1)= CCTK_PointerTo(aux)
         input_array(1)    = CCTK_PointerTo(intexp2)
         call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .      1, input_array,0, 0, input_array_type, 1,
     .      input_array_type, reduction_value)
     
         intexp2=aux
         
         input_array_type(1) = CCTK_VARIABLE_REAL
         reduction_value(1)= CCTK_PointerTo(aux)
         input_array(1)    = CCTK_PointerTo(intexpdel2)
         call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .      1, input_array,0, 0, input_array_type, 1,
     .      input_array_type, reduction_value)

         intexpdel2=aux

         

         input_array_type(1) = CCTK_VARIABLE_INT
         reduction_value(1)= CCTK_PointerTo(red_tmp)
         input_array(1)    = CCTK_PointerTo(inside_min_neg_count)
         call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .      1, input_array,0, 0, input_array_type, 1,
     .      input_array_type, reduction_value)
     
         inside_min_neg_count=red_tmp
         	 
         input_array_type(1) = CCTK_VARIABLE_INT
         reduction_value(1)= CCTK_PointerTo(red_tmp)
         input_array(1)    = CCTK_PointerTo(inside_min_count)
         call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .      1, input_array,0, 0, input_array_type, 1,
     .      input_array_type, reduction_value)
     
         inside_min_count=red_tmp

      end if


!     *******************************
!     ***   SPECTRAL COMPONENTS   ***
!     *******************************

!     For flow algorithm, find spectral components.
!     For this I need to recalculate the Legendre polynomials,
!     but I see no way around it.  Also, to avoid having to
!     define lots of 2D arrays I do the integrals inside
!     the loop.  This means that I have to take care to see
!     if I am on an edge or corner point. Notice also that
!     these integrals do not involve the area element.

      if (flow) then

         if (myproc.lt.npt*npp) then

!           Find h0.

            if (find_trapped_surface) then
               h0 = - trapped_surface_delta
            else
               h0 = zero
            end if

!           Find integrals.

            do j=1,l_nphi+1

!              Find phi.

               phi = dphi*dble(j+phi0) + phistart

               do i=1,l_ntheta+1

!                 Find sines and cosines of theta.

                  cost = costheta(i)
                  sint = sintheta(i)

!                 Find norm of gradient of horizon function.

                  grad = gradn(i,j)

!                 Find weight factor.

                  intw = dtp*(exp(i,j)-h0)*sint**2

!                 Modify weight factor at corners and edges.

                  if (((j.eq.1).or.(j.eq.l_nphi+1)).and.
     .               ((i.eq.1).or.(i.eq.l_ntheta+1))) then
                     intw = quarter*intw
                  else if (((j.eq.1).or.(j.eq.l_nphi+1)).or.
     .               ((i.eq.1).or.(i.eq.l_ntheta+1))) then
                     intw = half*intw
                  end if

!                 Find "sigma" for Nakamura flow (see Carstens paper).

                  if (nw.eq.0.0) then

                     sigma = zero

                  else

                     xw = xa(i,j) - xc
                     yw = ya(i,j) - yc
                     zw = za(i,j) - zc

!                    Calculate metric on surface.

                     det = txx(i,j)*tyy(i,j)*tzz(i,j)
     .                   + two*txy(i,j)*txz(i,j)*tyz(i,j)
     .                   - txx(i,j)*tyz(i,j)**2 - tyy(i,j)*txz(i,j)**2
     .                   - tzz(i,j)*txy(i,j)**2

                     idet = one/det

                     gupij(1,1) = idet*(tyy(i,j)*tzz(i,j)-tyz(i,j)**2)
                     gupij(2,2) = idet*(txx(i,j)*tzz(i,j)-txz(i,j)**2)
                     gupij(3,3) = idet*(txx(i,j)*tyy(i,j)-txy(i,j)**2)

                     gupij(1,2) = idet*(txz(i,j)*tyz(i,j)-tzz(i,j)*txy(i,j))
                     gupij(2,1) = gupij(1,2)
                     gupij(1,3) = idet*(txy(i,j)*tyz(i,j)-tyy(i,j)*txz(i,j))
                     gupij(3,1) = gupij(1,3)
                     gupij(2,3) = idet*(txy(i,j)*txz(i,j)-txx(i,j)*tyz(i,j))
                     gupij(3,2) = gupij(2,3)

                     call AHFinder_calcsigma(CCTK_ARGUMENTS,
     .               xw,yw,zw,gupij,sigma)

                  end if

!                 Monopole components.

                  aux = intw*grad

                  hflow0(0) = hflow0(0) + intw
                  cflow0(0) = cflow0(0) + aux
                  nflow0(0) = nflow0(0) + aux*sigma

!                 Axisymmetric components.

                  do l=1+stepz,lmax,1+stepz

                     aux  = intw*LEGEN(l,0,cost)
                     aux1 = aux*grad

                     hflow0(l) = hflow0(l) + aux
                     cflow0(l) = cflow0(l) + aux1
                     nflow0(l) = nflow0(l) + aux1*sigma

                  end do

!                 Non-axisymmetric components.

                  if (nonaxi) then

                     do m=1,lmax

                        aux = dble(m)*phi
                        sina = sin(aux)
                        cosa = cos(aux)

                        do l=m,lmax

                           aux  = intw*LEGEN(l,m,cost)

                           aux1 = aux*cosa
                           aux2 = aux1*grad
                           hflowc(l,m) = hflowc(l,m) + aux1
                           cflowc(l,m) = cflowc(l,m) + aux2
                           nflowc(l,m) = nflowc(l,m) + aux2*sigma

                           if (.not.refy) then
                              aux1 = aux*sina
                              aux2 = aux1*grad
                              hflows(l,m) = hflows(l,m) + aux1
                              cflows(l,m) = cflows(l,m) + aux2
                              nflows(l,m) = nflows(l,m) + aux2*sigma
                           end if

                        end do
                     end do

                  end if

               end do
            end do

         end if

!        Reduce integrals.

!        Axisymmetric components.

         auxi = lmax+1

         if (hw.ne.zero) then
            input_array_type(1) = CCTK_VARIABLE_REAL
            reduction_value(1)= CCTK_PointerTo(tempv)
            input_array(1)    = CCTK_PointerTo(hflow0)
            call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .         1, input_array,1, auxi, input_array_type, 1,
     .         input_array_type, reduction_value)

            hflow0 = tempv
	 
         end if

         if (cw.ne.zero) then
            input_array_type(1) = CCTK_VARIABLE_REAL
            reduction_value(1)= CCTK_PointerTo(tempv)
            input_array(1)    = CCTK_PointerTo(cflow0)
            call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .         1, input_array,1, auxi, input_array_type, 1,
     .         input_array_type, reduction_value)
     
            cflow0 = tempv

         end if

         if (nw.ne.zero) then
            input_array_type(1) = CCTK_VARIABLE_REAL
            reduction_value(1)= CCTK_PointerTo(tempv)
            input_array(1)    = CCTK_PointerTo(nflow0)
            call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .         1, input_array,1, auxi, input_array_type, 1,
     .         input_array_type, reduction_value)
            nflow0 = tempv

         end if

!        Non-axisymmetric components.

         if (nonaxi) then

            auxi = lmax*lmax

            if (hw.ne.zero) then
               input_array_type(1) = CCTK_VARIABLE_REAL
               reduction_value(1)= CCTK_PointerTo(tempm)
               input_array(1)    = CCTK_PointerTo(hflowc)
               call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .            1, input_array,1, auxi, input_array_type, 1,
     .            input_array_type, reduction_value)

               hflowc = tempm
            end if

            if (cw.ne.zero) then
               input_array_type(1) = CCTK_VARIABLE_REAL
               reduction_value(1)= CCTK_PointerTo(tempm)
               input_array(1)    = CCTK_PointerTo(cflowc)
               call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .            1, input_array,1, auxi, input_array_type, 1,
     .            input_array_type, reduction_value)

               cflowc = tempm
            end if

            if (nw.ne.zero) then
               input_array_type(1) = CCTK_VARIABLE_REAL
               reduction_value(1)= CCTK_PointerTo(tempm)
               input_array(1)    = CCTK_PointerTo(nflowc)
               call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .            1, input_array,1, auxi, input_array_type, 1,
     .            input_array_type, reduction_value)

               nflowc = tempm
            end if

            if (.not.refy) then

               if (hw.ne.zero) then
                  input_array_type(1) = CCTK_VARIABLE_REAL
                  reduction_value(1)= CCTK_PointerTo(tempm)
                  input_array(1)    = CCTK_PointerTo(hflows)
                  call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .               1, input_array,1, auxi, input_array_type, 1,
     .               input_array_type, reduction_value)

                  hflows = tempm
               end if

               if (cw.ne.zero) then
                  input_array_type(1) = CCTK_VARIABLE_REAL
                  reduction_value(1)= CCTK_PointerTo(tempm)
                  input_array(1)    = CCTK_PointerTo(cflows)
                  call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .               1, input_array,1, auxi, input_array_type, 1,
     .               input_array_type, reduction_value)

                  cflows = tempm
               end if

               if (nw.ne.zero) then
                  input_array_type(1) = CCTK_VARIABLE_REAL
                  reduction_value(1)= CCTK_PointerTo(tempm)
                  input_array(1)    = CCTK_PointerTo(nflows)
                  call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,reduction_handle, -1,
     .               1, input_array,1, auxi, input_array_type, 1,
     .               input_array_type, reduction_value)

                  nflows = tempm
               end if

            end if

         end if

      end if


!     *****************************************************
!     ***   RESCALE INTEGRALS ACCORDING TO SYMMETRIES   ***
!     *****************************************************

!     For cartoon multiply the integrals with 2*pi.

      if (cartoon) then

         intw = 6.283185307D0

         if (.not.flow) then
            intexp  = intw*intexp
            intexp2 = intw*intexp2
            intarea = intw*intarea
            intexpdel2 = intw*intexpdel2
         end if

         if (flow) then
            hflow0 = intw*hflow0
            cflow0 = intw*cflow0
            nflow0 = intw*nflow0
         end if

!     Other symmetries.

      else if (refx.or.refy.or.refz) then

         intw = one

         if (refx) intw = two*intw
         if (refy) intw = two*intw
         if (refz) intw = two*intw

         if (.not.flow) then
            intexp  = intw*intexp
            intexp2 = intw*intexp2
            intarea = intw*intarea
            intexpdel2 = intw*intexpdel2
         end if

!        Spectral components for flow.

         if (flow) then

!           Axisymmetric.

            hflow0 = intw*hflow0
            cflow0 = intw*cflow0
            nflow0 = intw*nflow0

!           Non-axisymmetric.

            if (nonaxi) then

               hflowc = intw*hflowc
               cflowc = intw*cflowc
               nflowc = intw*nflowc

               if (.not.refy) then
                  hflows = intw*hflows
                  cflows = intw*cflows
                  nflows = intw*nflows
               end if

            end if

         end if

      end if


!     *****************************
!     ***   DEALLOCATE MEMORY   ***
!     *****************************

   10 continue

      deallocate(costheta,sintheta)
      deallocate(cosphi,sinphi)
      deallocate(rr,xa,ya,za)
      deallocate(da,exp,gradn)
      deallocate(txx,tyy,tzz,txy,txz,tyz)
      deallocate(intmask)


!     ***************
!     ***   END   ***
!     ***************

      end subroutine AHFinder_int




```

AHFinder_min.F:
```
/*@@
  @file      AHFinder_min.F
  @date      April 1998
  @author    Miguel Alcubierre
  @desc 
             Minimization routine.
  @enddesc 
@@*/

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

      subroutine AHFinder_min(CCTK_ARGUMENTS,NN,status,logf)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS

      logical status,found

      integer i,NN
      integer l,m
      integer iter,itmax

      CCTK_REAL FTOL,FRET
      CCTK_REAL zero,half,one

      CCTK_REAL, dimension (NN)    :: P
      CCTK_REAL, dimension (NN,NN) :: XI

      character(len=200) :: logf

!     Description of variables:
!
!     i,j,l,m   Counters.
!
!     ITER      Number of iterations taken in minimization.
!     ITMAX     Maximum number of iterations allowed.
!
!     FTOL      Fractional tolerance for return criterion.
!
!     FRET      Value of fucntion on return from minimization.
!
!     P         Vector of coefficients.
!
!     XI        Matrix of initial directions.


!     ***********************************
!     ***   DEFINE  {zero,half,one}   ***
!     ***********************************

      zero = 0.0D0
      half = 0.5D0
      one  = 1.0D0


!     *********************************
!     ***   FIND INITIAL VECTOR P   ***
!     *********************************

      P = zero
      i = 0
 
!     Copy {xc,yc,zc}.

      if (wander) then
         if (.not.refx) then
            i = i+1
            P(1) = xc
         end if
         if (.not.refy) then
            i = i+1
            P(2) = yc
         end if
         if (.not.refz) then
            i = i+1
            P(3) = zc
         end if
      end if

!     Copy c0(l).

      do l=0,lmax,1+stepz
         i = i+1
         P(i) = c0(l)
      end do

!     Copy {cc,cs}.

      if (nonaxi) then

!        Copy cc(l,m).

         do l=1,lmax
            do m=1+stepx,l,1+stepx
               if (stepz*mod(l-m,2).eq.0) then
                  i = i+1
                  P(i) = cc(l,m)
               end if
            end do
         end do

!        Copy cs(l,m).

         if (.not.refy) then
            do l=1,lmax
               do m=1,l,1+stepx
                  if (stepz*mod(l-m,2).eq.0) then
                     i = i+1
                     P(i) = cs(l,m)
                  end if
               end do
            end do
         end if

      end if


!     *********************************************
!     ***   FIND MATRIX OF INITIAL DIRECTIONS   ***
!     *********************************************

!     The initial set of directions are taken to be
!     the unit vectors (the first index identifies the
!     components, and second index the vectors).

      XI = zero

      do i=1,NN
         XI(i,i) = one
      end do


!     ****************************************
!     ***   CALL MINIMIZATION SUBROUTINE   ***
!     ****************************************

!     Find ITMAX.

      ITMAX = ahf_maxiter

!     Find FTOL.  FTOL is the fractional tolerance in the
!     function value so that failure to decrease by more
!     than this amount on one interation signals that we
!     are done.

      FTOL = ahf_tol

!     Here I call the routine POWELL from Numerical Recipies.

      found = .false.
      firstfun = .true.

      call POWELL(CCTK_ARGUMENTS,P,XI,NN,FTOL,ITER,ITMAX,FRET,found)


!     ****************************
!     ***   FIND  {c0,cc,cs}   ***
!     ****************************

      i = 0

!     Find {xc,yc,zc}.

      if (wander) then
         if (.not.refx) then
            i = i+1
            xc = P(1)
         end if
         if (.not.refy) then
            i = i+1
            yc = P(2)
         end if
         if (.not.refz) then
            i = i+1
            zc = P(3)
         end if
      end if

!     Find c0(l).

      do l=0,lmax,1+stepz
         i = i+1
         c0(l) = P(i)
      end do

!     Find {cc,cs}.

      if (nonaxi) then

!        Find cc(l,m).

         do l=1,lmax
            do m=1+stepx,l,1+stepx
               if (stepz*mod(l-m,2).eq.0) then
                  i = i+1
                  cc(l,m) = P(i)
               end if
            end do
         end do

!        Find cs(l,m).

         if (.not.refy) then
            do l=1,lmax
               do m=1,l,1+stepx
                  if (stepz*mod(l-m,2).eq.0) then
                     i = i+1
                     cs(l,m) = P(i)
                  end if
               end do
            end do
         end if

      end if


!     ***************************************
!     ***   DECIDE ON THE RETURN STATUS   ***
!     ***************************************

!     If a minimum was found, set status to true.

      if (found) then

         status = .true.

!     If no minimum was found, it might still be because
!     there were to many iterations, in which case there
!     is a minimum, we just did not converge to it in the
!     maximum number of iterations allowed.

      else

         if (ITER.eq.ITMAX) then

            status = .true.

            if ((verbose.or.logfile).and.(myproc.eq.0)) then

               write(*,*)
               write(*,*) 'AHFinder:  Too many iterations.'

               if (logfile) then
                  open(11,file=logf,form='formatted',
     .            status='old',position='append')
                  write(11,*)
                  write(11,*) 'AHFinder:  Too many iterations.'
                  close(11)
               end if

            end if

         else

            status = .false.

         end if

      end if


!     ***************
!     ***   END   ***
!     ***************

      end subroutine AHFinder_min

```

AHFinder_gau.F:
```
/*@@
  @file      AHFinder_gau.F
  @date      October 1998
  @author    Miguel Alcubierre
  @desc
             Find gaussian curvature of surface.  The gaussian
             curvature is defined as R/2, where R is the Ricci
             scalar of the induced 2-geometry of the surface.

             As an extra "goody", this routine also integrates
             the equatorial circumference of the horizon and
             two polar circumferences at phi=0 and phi=pi/2.
  @enddesc
@@*/

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

      subroutine AHFinder_gau(CCTK_ARGUMENTS)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS
      DECLARE_CCTK_FUNCTIONS

      logical firstgau
      logical firstcal(4)

      integer i,j,k,l,m,n,p
      integer npoints,vindex
      integer param_table_handle,interp_handle,coord_system_handle,sum_handle
      integer ierror
      character(len=128) :: operator
      CCTK_INT nchars

      CCTK_INT rerror,error1,error2

      character(30) options_string

      CCTK_REAL LEGEN
      CCTK_REAL theta,phi,xp,yp,zp,rp
      CCTK_REAL cost,sint,cosp,sinp
      CCTK_REAL dtheta,dphi,dtp,idtheta,idphi,phistart
      CCTK_REAL trr,ttt,tpp,trt,trp,ttp,ft,fp
      CCTK_REAL deta,ideta
      CCTK_REAL nlx,nly,nlz,nux,nuy,nuz
      CCTK_REAL trxi,xi2
      CCTK_REAL zero,half,one,two,three,four,pi
      CCTK_REAL aux,sina,cosa
c      CCTK_REAL dt,idx,idy,idz
c      CCTK_REAL i2dx,i2dy,i2dz,idxx,idyy,idzz,idxy,idxz,idyz

      CCTK_REAL, dimension(3,3)     :: ug,xi
      CCTK_REAL, dimension(2,2)     :: ga,ua
      CCTK_REAL, dimension(2,2,2)   :: d1a,gammad,gamma
      CCTK_REAL, dimension(2,2,2,2) :: d2a,gamma2

      CCTK_POINTER, dimension(3) :: interp_coords
      CCTK_INT, dimension(7) :: in_array_indices
      CCTK_POINTER, dimension(7) :: out_arrays
      CCTK_INT, dimension(7) :: out_array_type_codes

      CCTK_REAL, allocatable, dimension(:,:) :: rr,xa,ya,za
      CCTK_REAL, allocatable, dimension(:,:) :: txx,tyy,tzz,txy,txz,tyz
      CCTK_REAL, allocatable, dimension(:,:) :: g11,g22,g12

      CCTK_REAL, dimension(3) :: ahf_centroid, rahf_centroid

      logical :: str_comp
      logical :: gaussf_exists
      external str_comp
!      CCTK_INT :: CCTK_IsFunctionAliased

      character(len=200) :: gaussf

!     Reduction variables
      CCTK_POINTER_TO_CONST, dimension(3) :: input_array
      CCTK_POINTER, dimension(1) :: reduction_value
      CCTK_POINTER, dimension(3) :: reduction_value3
      CCTK_INT, dimension(1) ::input_array_type
      CCTK_INT, dimension(3) ::input_array_type3
      
!     Declarations for macros.

c#include "EinsteinBase/ADMMacros/src/macro/ADM_Spacing_declare.h"
       CCTK_REAL :: dt
       CCTK_REAL :: idx, idy, idz
       CCTK_REAL :: i2dx, i2dy, i2dz
       CCTK_REAL :: i12dx, i12dy, i12dz
       CCTK_REAL :: idxx, idxy, idxz, idyy, idyz, idzz
       CCTK_REAL :: i12dxx, i12dyy, i12dzz
       CCTK_REAL :: i36dxy, i36dxz, i36dyz

#include "EinsteinBase/ADMMacros/src/macro/UPPERMET_declare.h"
#include "EinsteinBase/ADMMacros/src/macro/CHR2_declare.h"
#include "EinsteinBase/ADMMacros/src/macro/RICCI_declare.h"
#include "EinsteinBase/ADMMacros/src/macro/TRRICCI_declare.h"

!     Data.

      data firstgau    / .true. /
      data firstcal(1) / .true. /
      data firstcal(2) / .true. /
      data firstcal(3) / .true. /
      data firstcal(4) / .true. /

      save firstcal
      save firstgau

!     Description of variables:
!
!     i,j,k,
!     l,m,n,p    Counters.
!
!     npoints    Number of points to interpolate.
!
!     error1     Different from zero if radius is negative.
!     error2     Different from zero if outside computational domain.
!
!     theta      Latitude.
!     phi        Longitude.
!
!     cost       cos(theta)
!     sint       sin(theta)
!     cosp       cos(phi)
!     sinp       sin(phi)
!
!     dtheta     Grid spacing in theta.
!     dphi       Grid spacing in phi.
!     dtp        dtheta*dphi.
!
!     phistart   Origin for phi (normally 0, but for some symmetries -pi/2).
!
!     idtheta    1/(2 dtheta)
!     idphi      1/(2 dphi)
!
!     xp         x coordinate from surface centre.
!     yp         y coordinate from surface centre.
!     zp         z coordinate from surface centre.
!
!     rp         Radius.
!     rr         Radius array.
!
!     xa         Array with x coordinates from grid centre.
!     ya         Array with y coordinates from grid centre.
!     za         Array with z coordinates from grid centre.
!
!     txx        Interpolated gxx metric component.
!     tyy        Interpolated gyy metric component.
!     tzz        Interpolated gzz metric component.
!     txy        Interpolated gxy metric component.
!     txz        Interpolated gxz metric component.
!     tyz        Interpolated gyz metric component.
!
!     trr        3-metric component {r,r}.
!     ttt        3-metric component {theta,theta}.
!     tpp        3-metric component {phi,phi}.
!     trt        3-metric component {r,theta}.
!     trp        3-metric component {r,phi}.
!     ttp        3-metric component {theta,phi}.
!
!     ft         dr/dtheta
!     fp         dr/dphi
!
!     g11        2-metric component {theta,theta}.
!     g22        2-metric component {phi,phi}.
!     g12        2-metric component {theta,phi}.
!
!     gaussian   Gaussian curvature.
!
!     ug         3x3 array with inverse 3-metric.
!
!     xi_ij      3x3 array for extrinsic curvature of level sets
!                of horizon function.
!     trxi       Trace of xi.
!     xi2        Square of xi.
!
!     ga_ij      2x2 array with angular metric,
!     ua_ij      2x2 array with inverse angular metric.
!
!     deta       Determinant of angular metric.
!     ideta      1/deta
!
!     d1a_ijk    d ga
!                 i  kl
!
!     d2a_ijkl   d d ga
!                 i j  kl
!
!     gammad     Christoffel symbol with 3 indices down.
!
!     gamma      Christoffel symbol with first index up.
!
!     gamma2     Product of Christoffel symbols.


!     **************************
!     ***   DEFINE NUMBERS   ***
!     **************************

      zero  = 0.0D0
      half  = 0.5D0
      one   = 1.0D0
      two   = 2.0D0
      three = 3.0D0
      four  = 4.0D0

      pi = acos(-one)

!     Number of points to interpolate.

      if (myproc.eq.0) then
         npoints = (ntheta+1)*(nphi+1)
      else
         npoints = 1
      end if

!     ******************************************************
!     ***   Get the reduction handle for sum operation   ***
!     ******************************************************

      call CCTK_LocalArrayReductionHandle(sum_handle,"sum")

      if (sum_handle.lt.0) then
        call CCTK_WARN(1,"Cannot get handle for sum reduction ! Forgot to activate an implementation providing reduction operators ??")
      end if

!     **************************************
!     ***   ALLOCATE MEMORY FOR ARRAYS   ***
!     **************************************

      if (myproc.eq.0) then

         allocate(rr(1:ntheta+1,1:nphi+1))

         allocate(xa(1:ntheta+1,1:nphi+1))
         allocate(ya(1:ntheta+1,1:nphi+1))
         allocate(za(1:ntheta+1,1:nphi+1))

         allocate(txx(1:ntheta+1,1:nphi+1))
         allocate(tyy(1:ntheta+1,1:nphi+1))
         allocate(tzz(1:ntheta+1,1:nphi+1))
         allocate(txy(1:ntheta+1,1:nphi+1))
         allocate(txz(1:ntheta+1,1:nphi+1))
         allocate(tyz(1:ntheta+1,1:nphi+1))

         allocate(g11(1:ntheta+1,1:nphi+1))
         allocate(g22(1:ntheta+1,1:nphi+1))
         allocate(g12(1:ntheta+1,1:nphi+1))

      else

         allocate(rr(1,1))

         allocate(xa(1,1))
         allocate(ya(1,1))
         allocate(za(1,1))

         allocate(txx(1,1))
         allocate(tyy(1,1))
         allocate(tzz(1,1))
         allocate(txy(1,1))
         allocate(txz(1,1))
         allocate(tyz(1,1))

         allocate(g11(1,1))
         allocate(g22(1,1))
         allocate(g12(1,1))

      end if

      rr = zero

      xa = zero
      ya = zero
      za = zero

      txx = zero
      tyy = zero
      tzz = zero
      txy = zero
      txz = zero
      tyz = zero

      g11 = zero
      g22 = zero
      g12 = zero

      gaussian = zero


!     *********************************
!     ***   INITIALIZE PARAMETERS   ***
!     *********************************

!     Find {phistart,dtheta,dphi,dtp}.

      phistart = zero

      dtheta = pi/dble(ntheta)

      if (cartoon) then

         dphi    = zero
         dtp     = dtheta
         idphi   = one
         idtheta = half/dtheta

      else

         dphi = two*pi/dble(nphi)

         if (refz) dtheta = half*dtheta

         if (refx.and.refy) then
            dphi = 0.25D0*dphi
         else if (refx) then
            dphi = half*dphi
            phistart = - half*pi
         else if (refy) then
            dphi = half*dphi
         end if

         dtp = dtheta*dphi

         idtheta = half/dtheta
         idphi   = half/dphi

      end if

!     Initialize circumferences.

      circ_eq = zero
      meri_p1 = zero
      meri_p2 = zero

#include "EinsteinBase/ADMMacros/src/macro/ADM_Spacing.h"


!     *******************************************************
!     ***   FIND GAUSSIAN CURVATURE AS 3D GRID FUNCTION   ***
!     *******************************************************

!     Here I calculate the gaussian curvature of the level sets
!     of the horizon function as a 3D grid function.  Later I will
!     interpolate it onto the horizon.  This is cleaner than my old
!     method (see below).  It depends on less interpolations, and
!     the interpolations are done only after all derivatives have
!     been calculated.

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

!              Find covariant normal unit vector.

               aux = one/ahfgradn(i,j,k)

               nlx = ahfgradx(i,j,k)*aux
               nly = ahfgrady(i,j,k)*aux
               nlz = ahfgradz(i,j,k)*aux

!              Find upper spatial metric using standard macro.

#include "EinsteinBase/ADMMacros/src/macro/UPPERMET_guts.h"

               ug(1,1) = UPPERMET_UXX
               ug(2,2) = UPPERMET_UYY
               ug(3,3) = UPPERMET_UZZ

               ug(1,2) = UPPERMET_UXY
               ug(1,3) = UPPERMET_UXZ
               ug(2,3) = UPPERMET_UYZ

               ug(2,1) = ug(1,2)
               ug(3,1) = ug(1,3)
               ug(3,2) = ug(2,3)

!              Find contravariant normal unit vector.

               nux = ug(1,1)*nlx + ug(1,2)*nly + ug(1,3)*nlz
               nuy = ug(2,1)*nlx + ug(2,2)*nly + ug(2,3)*nlz
               nuz = ug(3,1)*nlx + ug(3,2)*nly + ug(3,3)*nlz

!              Find Christoffel symbols using standard macros.

#include "EinsteinBase/ADMMacros/src/macro/CHR2_guts.h"

!              Find extrinsic curvature of the 2-surfaces defined
!              as the level sets of the horizon function.  The
!              extrinsic curvature is defined as:
!                         __
!              xi   =  -  \/  n
!                ij         (i j)
!                    __
!              where \/ is the 3-dimensional covariant derivative and
!              n_i is the unit normal vector to the level sets of the
!              horizon function.

               xi(1,1) = - (ahfgradx(i+1,j,k)/ahfgradn(i+1,j,k)
     .                 - ahfgradx(i-1,j,k)/ahfgradn(i-1,j,k))/(two*dx)
     .                 + (CHR2_XXX*nlx + CHR2_YXX*nly + CHR2_ZXX*nlz)

               xi(2,2) = - (ahfgrady(i,j+1,k)/ahfgradn(i,j+1,k)
     .                 - ahfgrady(i,j-1,k)/ahfgradn(i,j-1,k))/(two*dy)
     .                 + (CHR2_XYY*nlx + CHR2_YYY*nly + CHR2_ZYY*nlz)

               xi(3,3) = - (ahfgradz(i,j,k+1)/ahfgradn(i,j,k+1)
     .                 - ahfgradz(i,j,k-1)/ahfgradn(i,j,k-1))/(two*dz)
     .                 + (CHR2_XZZ*nlx + CHR2_YZZ*nly + CHR2_ZZZ*nlz)

               xi(1,2) = - (ahfgradx(i,j+1,k)/ahfgradn(i,j+1,k)
     .                 - ahfgradx(i,j-1,k)/ahfgradn(i,j-1,k))/(four*dy)
     .                 -   (ahfgrady(i+1,j,k)/ahfgradn(i+1,j,k)
     .                 - ahfgrady(i-1,j,k)/ahfgradn(i-1,j,k))/(four*dx)
     .                 + (CHR2_XXY*nlx + CHR2_YXY*nly + CHR2_ZXY*nlz)

               xi(1,3) = - (ahfgradx(i,j,k+1)/ahfgradn(i,j,k+1)
     .                 - ahfgradx(i,j,k-1)/ahfgradn(i,j,k-1))/(four*dz)
     .                 -   (ahfgradz(i+1,j,k)/ahfgradn(i+1,j,k)
     .                 - ahfgradz(i-1,j,k)/ahfgradn(i-1,j,k))/(four*dx)
     .                 + (CHR2_XXZ*nlx + CHR2_YXZ*nly + CHR2_ZXZ*nlz)

               xi(2,3) = - (ahfgrady(i,j,k+1)/ahfgradn(i,j,k+1)
     .                 - ahfgrady(i,j,k-1)/ahfgradn(i,j,k-1))/(four*dz)
     .                 -   (ahfgradz(i,j+1,k)/ahfgradn(i,j+1,k)
     .                 - ahfgradz(i,j-1,k)/ahfgradn(i,j-1,k))/(four*dy)
     .                 + (CHR2_XYZ*nlx + CHR2_YYZ*nly + CHR2_ZYZ*nlz)

               xi(2,1) = xi(1,2)
               xi(3,1) = xi(1,3)
               xi(3,2) = xi(2,3)

!              Find trace of xi.

               aux = zero

               do l=1,3
                  do m=1,3
                     aux = aux + ug(l,m)*xi(l,m)
                  end do
               end do

               trxi = aux

!              Find square of xi.

               aux = zero

               do l=1,3
                  do m=1,3
                     do n=1,3
                        do p=1,3
                           aux = aux + ug(l,m)*ug(n,p)*xi(l,n)*xi(m,p)
                        end do
                     end do
                  end do
               end do

               xi2 = aux

!              Find 3-Ricci and 3-Ricci scalar using standard macros.

#include "EinsteinBase/ADMMacros/src/macro/RICCI_guts.h"
#include "EinsteinBase/ADMMacros/src/macro/TRRICCI_guts.h"

!              Find 2-Ricci scalar using the contracted Gauss-Codazzi
!              relations:
!
!              (2)     (3)         a  b (3)              2           ab
!                 R  =    R  -  2 n  n     R   +  (tr xi)   -  xi  xi
!                                           ab                   ab

               aux = TRRICCI_TRRICCI - two*(nux**2*RICCI_RXX
     .             + nuy**2*RICCI_RYY + nuz**2*RICCI_RZZ
     .             + two*(nux*nuy*RICCI_RXY + nux*nuz*RICCI_RXZ
     .             + nuy*nuz*RICCI_RYZ))

               aux = aux + trxi**2 - xi2

!              Find gaussian curvature.  The gaussian curvature is
!              defined as R/2, with R the Ricci scalar of the surfaces.

               ahfgauss(i,j,k) = half*aux

!              Undefine macros!

#include "EinsteinBase/ADMMacros/src/macro/UPPERMET_undefine.h"
#include "EinsteinBase/ADMMacros/src/macro/CHR2_undefine.h"
#include "EinsteinBase/ADMMacros/src/macro/RICCI_undefine.h"
#include "EinsteinBase/ADMMacros/src/macro/TRRICCI_undefine.h"

            end do
         end do
      end do

!     Boundaries.

      ahfgauss(1,:,:) = ahfgauss(2,:,:)
      ahfgauss(:,1,:) = ahfgauss(:,2,:)
      ahfgauss(:,:,1) = ahfgauss(:,:,2)

      ahfgauss(nx,:,:) = ahfgauss(nx-1,:,:)
      ahfgauss(:,ny,:) = ahfgauss(:,ny-1,:)
      ahfgauss(:,:,nz) = ahfgauss(:,:,nz-1)

!     Synchronize.

      call CCTK_SyncGroup(ierror,cctkGH,"ahfinder::ahfinder_gauss")


!     *************************************
!     ***   FIND INTERPOLATING POINTS   ***
!     *************************************

!     Initialize {error1,error2}.

      error1 = 0
      error2 = 0

!     Notice that everything here is done on processor zero!

      if (myproc.eq.0) then

         avgx = 0.0D0
         avgy = 0.0D0
         avgz = 0.0D0

         do j=1,nphi+1
            do i=1,ntheta+1

!              Find {theta,phi}.

               theta = dtheta*dble(i-1)
               phi   = dphi*dble(j-1) + phistart

!              Find sines and cosines.

               cost = cos(theta)
               sint = sin(theta)

               cosp = cos(phi)
               sinp = sin(phi)

!              Find radius rp.

               rp = c0(0)

               do l=1+stepz,lmax,1+stepz
                  rp = rp + c0(l)*LEGEN(l,0,cost)
               end do

!              Notice how the sum over m is first.  This will allow
!              me to use the recursion relations to avoid having to
!              start from scratch every time.  Also, I sum over all
!              l s even if I do not want some terms.  This is
!              because in order to use the recursion relations I
!              need all polynomials.

               if (nonaxi) then
                  do m=1,lmax
                     aux = dble(m)*phi
                     sina = sin(aux)
                     cosa = cos(aux)
                     do l=m,lmax
                        aux = LEGEN(l,m,cost)
                        rp = rp + aux*cc(l,m)*cosa
                        if (.not.refy) then
                           rp = rp + aux*cs(l,m)*sina
                        end if
                     end do
                  end do
               end if

!              Check for negative radius.

               if (rp.le.zero) then
                  error1 = 1
               end if

!              Save radius array.

               rr(i,j) = rp

!              Find {xa,ya,za}

               xa(i,j) = rp*sint*cosp + xc
               ya(i,j) = rp*sint*sinp + yc
               za(i,j) = rp*cost + zc

!              Check if we are within bounds.

               xp = xa(i,j)
               yp = ya(i,j)
               zp = za(i,j)

               if ((xp.gt.xmx).or.(xp.lt.xmn).or.
     .             (yp.gt.ymx).or.(yp.lt.ymn).or.
     .             (zp.gt.zmx).or.(zp.lt.zmn)) then
                  error2 = 1
               end if

!              Add to sums for average position.

               avgx = avgx + xp
               avgy = avgy + yp
               avgz = avgz + zp

            end do
         end do

!        Find position of horizon centroid.

         avgx = avgx/dble(npoints)
         avgy = avgy/dble(npoints)
         avgz = avgz/dble(npoints)

         ahf_centroid(1) = avgx
         ahf_centroid(2) = avgy
         ahf_centroid(3) = avgz

!        Take symmetries into account.

         if (refx) ahf_centroid(1) = xc
         if (refy) ahf_centroid(2) = yc
         if (refz) ahf_centroid(3) = zc

!     Other processors.

      else

         xa = half*(xmx+xmn)
         ya = half*(ymx+ymn)
         za = half*(zmx+zmn)

         ahf_centroid(1) = zero
         ahf_centroid(2) = zero
         ahf_centroid(3) = zero
      end if


!     Reduce the errors across processors (all processors must
!     know about this since all will participate on the interpolation
!     below).

      input_array_type(1) = CCTK_VARIABLE_INT
      reduction_value(1)= CCTK_PointerTo(rerror)
      input_array(1)    = CCTK_PointerTo(error1)
      
      call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,sum_handle, -1,
     .   1, input_array,0, 0, input_array_type, 1,
     .   input_array_type, reduction_value)
      
      if (ierror.ne.0) then
         call CCTK_WARN(1,"Reduction failed!")
      end if
      error1 = rerror

      input_array(1)    = CCTK_PointerTo(error2)
      call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,sum_handle, -1,
     .   1, input_array,0, 0, input_array_type, 1,
     .   input_array_type, reduction_value)

      if (ierror.ne.0) then
         call CCTK_WARN(1,"Reduction failed!")
      end if
      error2 = rerror
     
      input_array(1) = CCTK_PointerTo(ahf_centroid(1))
      input_array(2) = CCTK_PointerTo(ahf_centroid(2))
      input_array(3) = CCTK_PointerTo(ahf_centroid(3))
            
      reduction_value3(1) = CCTK_PointerTo(rahf_centroid(1))
      reduction_value3(2) = CCTK_PointerTo(rahf_centroid(2))
      reduction_value3(3) = CCTK_PointerTo(rahf_centroid(3))
      
      input_array_type3(1) = CCTK_VARIABLE_REAL
      input_array_type3(2) = CCTK_VARIABLE_REAL
      input_array_type3(3) = CCTK_VARIABLE_REAL
      
      call CCTK_ReduceArraysGlobally(ierror, cctkGH, -1,sum_handle, -1,
     .   3, input_array,0, 0, input_array_type3, 3,
     .   input_array_type3, reduction_value3)

      if (ierror.ne.0) then
         call CCTK_WARN(1,"Reduction failed!")
      end if

      if ( ( horizon_to_announce_centroid .gt. 0 ) .and. 
     .     ( horizon_to_announce_centroid .eq. mfind ) ) then

         call CCTK_IsFunctionAliased(ierror, 
     .                                "SetDriftCorrectPosition")
         if ( ierror .eq. 1 ) then
            call CCTK_INFO("Announcing centroid to DriftCorrect")
            call SetDriftCorrectPosition ( cctkGH, ahf_centroid(1),
     .                                             ahf_centroid(2), 
     .                                             ahf_centroid(3) )
         end if
      end if

      if ( ( horizon_to_output_centroid .gt. 0 ) .and.
     .     ( horizon_to_output_centroid .eq. mfind ) ) then

         ahf_centroid_x = rahf_centroid(1)
         ahf_centroid_y = rahf_centroid(2)
         ahf_centroid_z = rahf_centroid(3)

         if (verbose) then
            write(*,*)
            write(6,*) 'AHFinder_gau: ahf_centroid_x = ',
     .                                             ahf_centroid_x
            write(6,*) 'AHFinder_gau: ahf_centroid_y = ',
     .                                             ahf_centroid_y
            write(6,*) 'AHFinder_gau: ahf_centroid_z = ',
     .                                             ahf_centroid_z
         end if
      end if


!     If there was an error then return from the subroutine
!     (but remember to deallocate the arrays first!).

      if ((error1.ne.0).or.(error2.ne.0)) then
         deallocate(rr)
         deallocate(xa,ya,za)
         deallocate(txx,tyy,tzz,txy,txz,tyz)
         deallocate(g11,g22,g12)
         return
      end if


!     ***********************
!     ***   INTERPOLATE   ***
!     ***********************

!     Here I should really only interpolate the gaussian curvature.
!     The interpolation of the metric is only needed for the old
!     gaussian curvature calculation (which I dont use any more),
!     and for the calculation of the circumferences (which really
!     should be done in the routine AHFinder_int.F).  I need to fix
!     this sometime soon! (October 2000).

!     parameter, local interpolator, and coordinate system handle.
      param_table_handle = -1
      interp_handle = -1
      coord_system_handle = -1

      options_string = "order = " // char(ichar('0') + interpolation_order)
      call Util_TableCreateFromString (param_table_handle, options_string)
      if (param_table_handle .lt. 0) then
        call CCTK_WARN(0,"Cannot create parameter table for interpolator")
      endif

      call CCTK_FortranString (nchars, interpolation_operator, operator)
      call CCTK_InterpHandle (interp_handle, operator)
      if (interp_handle .lt. 0) then
        call CCTK_WARN(0,"Cannot get handle for interpolation ! Forgot to activate an implementation providing interpolation operators ??")
      endif

      call CCTK_CoordSystemHandle (coord_system_handle, "cart3d")
      if (coord_system_handle .lt. 0) then
        call CCTK_WARN(0,"Cannot get handle for cart3d coordinate system ! Forgot to activate an implementation providing coordinates ??")
      endif


!     fill in the input/output arrays for the interpolator
      interp_coords(1) = CCTK_PointerTo(xa)
      interp_coords(2) = CCTK_PointerTo(ya)
      interp_coords(3) = CCTK_PointerTo(za)

      call CCTK_VarIndex (vindex, "admbase::gxx")
      in_array_indices(1) = vindex
      call CCTK_VarIndex (vindex, "admbase::gyy")
      in_array_indices(2) = vindex
      call CCTK_VarIndex (vindex, "admbase::gzz")
      in_array_indices(3) = vindex
      call CCTK_VarIndex (vindex, "admbase::gxy")
      in_array_indices(4) = vindex
      call CCTK_VarIndex (vindex, "admbase::gxz")
      in_array_indices(5) = vindex
      call CCTK_VarIndex (vindex, "admbase::gyz")
      in_array_indices(6) = vindex
      call CCTK_VarIndex (vindex, "ahfinder::ahfgauss")
      in_array_indices(7) = vindex

      out_arrays(1) = CCTK_PointerTo(txx)
      out_arrays(2) = CCTK_PointerTo(tyy)
      out_arrays(3) = CCTK_PointerTo(tzz)
      out_arrays(4) = CCTK_PointerTo(txy)
      out_arrays(5) = CCTK_PointerTo(txz)
      out_arrays(6) = CCTK_PointerTo(tyz)
      out_arrays(7) = CCTK_PointerTo(gaussian)

      out_array_type_codes = CCTK_VARIABLE_REAL


!     Interpolation.
      call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     .                            param_table_handle, coord_system_handle,
     .                            npoints, CCTK_VARIABLE_REAL, interp_coords,
     .                            7, in_array_indices,
     .                            7, out_array_type_codes, out_arrays)
      if (ierror < 0) then
        call CCTK_WARN (1, "interpolator call returned an error code");
      endif

!     release parameter table
      call Util_TableDestroy (ierror, param_table_handle)


!     *********************************
!     ***   FIND SPHERICAL METRIC   ***
!     *********************************

      if (myproc.eq.0) then

         do j=1,nphi+1
            do i=1,ntheta+1

!              Find {theta,phi}.

               theta = dtheta*dble(i-1)
               phi   = dphi*dble(j-1) + phistart

!              Find {rp}.

               rp = rr(i,j)

!              Find sines and cosines.

               cost = cos(theta)
               sint = sin(theta)

               cosp = cos(phi)
               sinp = sin(phi)

!              Find metric in spherical coordinates.

               trr = sint**2*(txx(i,j)*cosp**2
     .             + tyy(i,j)*sinp**2) + tzz(i,j)*cost**2
     .             + two*sint*(txy(i,j)*sint*cosp*sinp
     .             + cost*(txz(i,j)*cosp + tyz(i,j)*sinp))

               ttt = rp**2*(cost**2*(txx(i,j)*cosp**2
     .             + tyy(i,j)*sinp**2) + tzz(i,j)*sint**2
     .             + two*cost*(txy(i,j)*cost*cosp*sinp
     .             - sint*(txz(i,j)*cosp + tyz(i,j)*sinp)))

               tpp = (rp*sint)**2*(txx(i,j)*sinp**2 + tyy(i,j)*cosp**2
     .             - two*txy(i,j)*cosp*sinp)

               trt = rp*(sint*cost*(txx(i,j)*cosp**2 + tyy(i,j)*sinp**2
     .             - tzz(i,j) + two*txy(i,j)*sinp*cosp)
     .             + (cost**2-sint**2)*(txz(i,j)*cosp + tyz(i,j)*sinp))

               trp = rp*sint*(sint*(cosp*sinp*(tyy(i,j) - txx(i,j))
     .             + txy(i,j)*(cosp**2 - sinp**2))
     .             + cost*(cosp*tyz(i,j) - sinp*txz(i,j)))

               ttp = rp**2*sint*(cost*(sinp*cosp*(tyy(i,j) - txx(i,j))
     .             + (cosp**2 - sinp**2)*txy(i,j))
     .             + sint*(sinp*txz(i,j) - cosp*tyz(i,j)))

!              Find derivatives  {ft,fp}.  For interior points I
!              use centered differences, and for the boundary points
!              I use second order one-sided differences.

               if ((i.ne.1).and.(i.ne.ntheta+1)) then
                  ft = idtheta*(rr(i+1,j) - rr(i-1,j))
               else if (i.eq.1) then
                  ft = - idtheta*(three*rr(1,j)
     .               - four*rr(2,j) + rr(3,j))
               else
                  ft = + idtheta*(three*rr(ntheta,j)
     .               - four*rr(ntheta,j) + rr(ntheta-1,j))
               end if

               if (nonaxi) then
                  if ((j.ne.1).and.(j.ne.nphi+1)) then
                     fp = idphi*(rr(i,j+1) - rr(i,j-1))
                  else if (j.eq.1) then
                     fp = - idphi*(three*rr(i,1)
     .                  - four*rr(i,2) + rr(i,3))
                  else
                     fp = + idphi*(three*rr(i,nphi)
     .                  - four*rr(i,nphi) + rr(i,nphi-1))
                  end if
               else
                  fp = zero
               end if

!              Find induced metric on the surface.

               g11(i,j) = ttt + trr*ft**2 + two*trt*ft
               g22(i,j) = tpp + trr*fp**2 + two*trp*fp
               g12(i,j) = ttp + trr*ft*fp + trp*ft + trt*fp

            end do
         end do

      end if


!     ************************************
!     ***   CALCULATE CIRCUMFERENCES   ***
!     ************************************

      if (myproc.eq.0) then

!        Equatorial circumference.

         if (refz) then

            do j=1,nphi
               circ_eq = circ_eq + dphi
     .            *sqrt(abs(half*(g22(ntheta+1,j) + g22(ntheta+1,j+1))))
            end do

         else

            aux = half*pi/dtheta
            i = int(aux)
            aux = aux - int(aux)

            if (cartoon) then
               circ_eq = 6.283185307D0*sqrt(g22(i,0))
            else
               do j=1,nphi
                  circ_eq = circ_eq + dphi
     .               *((one-aux)*sqrt(abs(half*(g22(i,j) + g22(i,j+1))))
     .               + aux*sqrt(abs(half*(g22(i+1,j) + g22(i+1,j+1)))))
               end do
            end if
         end if

!        Meridians.

         do i=1,ntheta
            meri_p1 = meri_p1 + dtheta
     .         *sqrt(abs(half*(g11(i,1) + g11(i+1,1))))
         end do

         if (cartoon) then
            meri_p2 = meri_p1
         else if (refx.and.refy) then
            do i=1,ntheta
               meri_p2 = meri_p2 + dtheta
     .            *sqrt(abs(half*(g11(i,nphi+1) + g11(i+1,nphi+1))))
            end do
         else
            aux = half*pi/dphi
            j = int(aux)
            aux = aux - int(aux)
            do i=1,ntheta
               meri_p2 = meri_p2 + dtheta
     .            *((one-aux)*sqrt(abs(half*(g11(i,j) + g11(i,j))))
     .            + aux*sqrt(abs(half*(g11(i,j+1) + g11(i,j+1)))))
            end do
         end if

!        Rescale the integrals according to symmetries.

         if (.not.cartoon) then
            if (refx) circ_eq = two*circ_eq
            if (refy) circ_eq = two*circ_eq
         end if

         if (refz) then
            meri_p1 = two*meri_p1
            meri_p2 = two*meri_p2
         end if

      end if


!     *************************************************
!     ***   OLD CALCULATION OF GAUSSIAN CURVATURE   ***
!     *************************************************

!     This is the old calculation of the gaussian curvature.
!     It is correct as far as I know, but it depends on taking
!     second derivatives of the interpolated metric, and this
!     seems not to behave well numerically (we would need higher
!     order interpolation).  I did not want to delete this code
!     since it might be useful in the future, so here I just jump
!     over it.

      if (.false.) then

!     The Gaussian curvature of the surface is defined as R/2
!     where R is the Ricci scalar of the two-geometry.  I can
!     now calculate the Ricci scalar using the spherical metric
!     components {ttt,tpp,ttp}.

!     Initialize arrays.

      gaussian = zero

      ga(1,1) = one
      ga(2,2) = one
      ga(1,2) = zero
      ga(2,1) = zero

      ua(1,1) = one
      ua(2,2) = one
      ua(1,2) = zero
      ua(2,1) = zero

      d1a = zero
      d2a = zero

      gamma  = zero
      gamma2 = zero
      gammad = zero

      if (myproc.eq.0) then

!        Interior points.

         do j=2,nphi
            do i=2,ntheta

!              Find angular metric.

               ga(1,1) = g11(i,j)
               ga(2,2) = g22(i,j)
               ga(1,2) = g12(i,j)
               ga(2,1) = g12(i,j)

!              Find determinant of angular metric.

               deta  = ga(1,1)*ga(2,2) - ga(1,2)**2
               ideta = one/deta

!              Find inverse angular metric.

               ua(1,1) = + ga(2,2)*ideta
               ua(2,2) = + ga(1,1)*ideta
               ua(1,2) = - ga(1,2)*ideta
               ua(2,1) = - ga(2,1)*ideta

!              First derivatives of angular metric.

               d1a(1,1,1) = idtheta*(g11(i+1,j) - g11(i-1,j))
               d1a(1,2,2) = idtheta*(g22(i+1,j) - g22(i-1,j))
               d1a(1,1,2) = idtheta*(g12(i+1,j) - g12(i-1,j))
               d1a(1,2,1) = d1a(1,1,2)

               if (nonaxi) then
                  d1a(2,1,1) = idphi*(g11(i,j+1) - g11(i,j-1))
                  d1a(2,2,2) = idphi*(g22(i,j+1) - g22(i,j-1))
                  d1a(2,1,2) = idphi*(g12(i,j+1) - g12(i,j-1))
                  d1a(2,2,1) = d1a(2,1,2)
               else
                  d1a(2,1,1) = zero
                  d1a(2,2,2) = zero
                  d1a(2,1,2) = zero
                  d1a(2,2,1) = zero
               end if

!              Second derivatives of angular metric.

               d2a(1,1,1,1) = four*idtheta**2*(g11(i+1,j)
     .                      - two*g11(i,j) + g11(i-1,j))
               d2a(1,1,2,2) = four*idtheta**2*(g22(i+1,j)
     .                      - two*g22(i,j) + g22(i-1,j))
               d2a(1,1,1,2) = four*idtheta**2*(g12(i+1,j)
     .                      - two*g12(i,j) + g12(i-1,j))

               if (nonaxi) then
                  d2a(2,2,1,1) = four*idphi**2*(g11(i,j+1)
     .                         - two*g11(i,j) + g11(i,j-1))
                  d2a(2,2,2,2) = four*idphi**2*(g22(i,j+1)
     .                         - two*g22(i,j) + g22(i,j-1))
                  d2a(2,2,1,2) = four*idphi**2*(g12(i,j+1)
     .                         - two*g12(i,j) + g12(i,j-1))

                  d2a(1,2,1,1) = (g11(i+1,j+1) - g11(i+1,j-1)
     .                         - g11(i-1,j+1) + g11(i-1,j-1))
     .                         *idtheta*idphi
                  d2a(1,2,2,2) = (g22(i+1,j+1) - g22(i+1,j-1)
     .                         - g22(i-1,j+1) + g22(i-1,j-1))
     .                         *idtheta*idphi
                  d2a(1,2,1,2) = (g12(i+1,j+1) - g12(i+1,j-1)
     .                         - g12(i-1,j+1) + g12(i-1,j-1))
     .                         *idtheta*idphi
               else
                  d2a(2,2,1,1) = zero
                  d2a(2,2,2,2) = zero
                  d2a(2,2,1,2) = zero
                  d2a(1,2,1,1) = zero
                  d2a(1,2,2,2) = zero
                  d2a(1,2,1,2) = zero
               end if

               d2a(1,1,2,1) = d2a(1,1,1,2)
               d2a(2,2,2,1) = d2a(2,2,1,2)
               d2a(1,2,2,1) = d2a(1,2,1,2)

               d2a(2,1,1,1) = d2a(1,2,1,1)
               d2a(2,1,2,2) = d2a(1,2,2,2)
               d2a(2,1,1,2) = d2a(1,2,1,2)
               d2a(2,1,2,1) = d2a(1,2,2,1)

!              Add correction terms to derivatives of g_{phi,phi}.
!              Near the axis, it turns out that the lower order
!              contributions to the derivatives of g_{phi,phi}
!              cancel out, and the gaussian curvature is made only
!              of higher order terms that the centered finite difference
!              approximations get wrong!  So here I add higher order
!              corrections to make sure that I get correctly the
!              first two terms of the Taylor series (assuming that
!              for small theta  g_{phi,phi} = f(r,phi) sin(theta)^2).

               theta = dtheta*dble(i-1)

               d1a(1,2,2) = d1a(1,2,2) + (two/three)*sin(theta)
     .                    *(g22(i+1,j) - two*g22(i,j) + g22(i-1,j))

               d2a(1,1,2,2) = d2a(1,1,2,2) + one/three
     .                    *(g22(i+1,j) - two*g22(i,j) + g22(i-1,j))

               if (nonaxi) then
                  d2a(1,2,2,2) = d2a(1,2,2,2) + (two/three)*sin(theta)
     .               *((g22(i+1,j+1) - two*g22(i,j+1) + g22(i-1,j+1))
     .               - (g22(i+1,j-1) - two*g22(i,j-1) + g22(i-1,j-1)))
     .               *idphi
                  d2a(2,1,2,2) = d2a(1,2,2,2)
               end if

!              Find Christoffel symbols.

               do l=1,2
                  do m=1,2
                     do n=1,2
                        gammad(l,m,n) = half*(d1a(m,n,l) + d1a(n,m,l)
     .                                - d1a(l,m,n))
                     end do
                  end do
               end do

               do l=1,2
                  do m=1,2
                     do n=1,2
                        aux = zero
                        do k=1,2
                           aux = aux + ua(l,k)*gammad(k,m,n)
                        end do
                        gamma(l,m,n) = aux
                     end do
                  end do
               end do

               do k=1,2
                  do l=1,2
                     do m=1,2
                        do n=1,2
                           aux = zero
                           do p=1,2
                              aux = aux + gamma(p,k,l)*gammad(p,m,n)
                           end do
                           gamma2(k,l,m,n) = aux
                        end do
                     end do
                  end do
               end do

!              Find gaussian curvature.

               aux = zero

               do k=1,2
                  do l=1,2
                     do m=1,2
                        do n=1,2
                           aux = aux + ua(k,l)*ua(m,n)
     .                         *(d2a(k,n,l,m) - d2a(k,l,m,n)
     .                         + gamma2(k,m,l,n) - gamma2(k,l,m,n))
                        end do
                     end do
                  end do
               end do

               gaussian(i,j) = half*aux

            end do
         end do

!        Boundaries.

         gaussian(1,:) = two*gaussian(2,:) - gaussian(3,:)
         gaussian(ntheta+1,:) = two*gaussian(ntheta,:)
     .                      - gaussian(ntheta-1,:)

         gaussian(:,1) = two*gaussian(:,2) - gaussian(:,3)
         gaussian(:,nphi+1) = two*gaussian(:,nphi)
     .                    - gaussian(:,nphi-1)

      end if

      end if


!     ************************************
!     ***   INITIALIZE FIRSTGAU FLAG   ***
!     ************************************

      if (find3) then
         firstgau = firstcal(mfind)
         firstcal(mfind) = .false.
      else
         firstgau = firstcal(4)
         firstcal(4) = .false.
      end if


!     ***********************************
!     ***   SAVE GAUSSIAN CURVATURE   ***
!     ***********************************

      if (myproc.eq.0) then

         if (find3) then
            if (mfind.eq.1) then
               gaussf = filestr(1:nfile)//"/ahf_0.gauss"
            else if (mfind.eq.2) then
               gaussf = filestr(1:nfile)//"/ahf_1.gauss"
            else
               gaussf = filestr(1:nfile)//"/ahf_2.gauss"
            end if
         else
            gaussf = filestr(1:nfile)//"/ahf.gauss"
         end if

         inquire(file=gaussf, exist=gaussf_exists)

         if (firstgau) then
            if (find3) then
               if (mfind.eq.3) then
                  firstgau = .false.
               end if
            else
               firstgau = .false.
            end if
         end if

!        On first call replace file.

         if (.not.gaussf_exists) then

           call AHFinder_WriteGaussHeader(CCTK_PASS_FTOF, gaussf)

!        On subsequent calls, append to file.

         else

            open(11,file=gaussf,form='formatted', status='old',
     .          position='append')

            write(11,*)
            write(11,"(A11,I4)")    '# Time step',cctk_iteration
            write(11,"(A6,ES11.3)") '# Time',cctk_time
            write(11,"(A6,I4)")     '# Call',ahf_ncall

         end if

!        Save data points.

         do i=1,ntheta+1
            do j=1,nphi+1
               write(11,"(ES11.3)") gaussian(i,j)
            end do
         end do

!        Close file.

         close(11)

      end if


!     *****************************
!     ***   DEALLOCATE MEMORY   ***
!     *****************************

      deallocate(rr)
      deallocate(xa,ya,za)
      deallocate(txx,tyy,tzz,txy,txz,tyz)
      deallocate(g11,g22,g12)


!     ***************
!     ***   END   ***
!     ***************

      end subroutine AHFinder_gau


!     ******************************************
!     *** String comparison utility function ***
!     ******************************************

      function str_comp(a1,a2)

      logical :: str_comp
      character(len=*),intent(in) :: a1, a2

      if ( ( verify(trim(a1),trim(a2)).eq.0 )  .and.
     .                     ( len_trim(a1) .eq. len_trim(a2) ) ) then
        str_comp = .true.
      else
        str_comp = .false.
      end if

      end function str_comp

```

AHFinder_dis.F:
```
/*@@
  @file      AHFinder_dis.F
  @date      September 2001
  @author    Miguel Alcubierre
  @desc
             Routine to calculate proper distances between horizons.
  @enddesc
@@*/

#include "cctk.h"

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

      subroutine AHFinder_dis(CCTK_ARGUMENTS)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS
      DECLARE_CCTK_FUNCTIONS

      integer i,l,m
      integer np,npoints,vindex,ierror
      integer param_table_handle,interp_handle,coord_system_handle
      character(30) options_string
      character(128) operator
      CCTK_INT nchars

      CCTK_POINTER, dimension(3) :: interp_coords
      CCTK_INT, dimension(6) :: in_array_indices
      CCTK_POINTER, dimension(6) :: out_arrays
      CCTK_INT, dimension(6) :: out_array_type_codes

      CCTK_REAL LEGEN
      CCTK_REAL zero,half,one,two,pi
      CCTK_REAL x12,y12,z12,r12,rho12
      CCTK_REAL phi,cost,sint,cosp,sinp
      CCTK_REAL x1,y1,z1,r1
      CCTK_REAL x2,y2,z2,r2
      CCTK_REAL ddx,ddy,ddz,d12
      CCTK_REAL aux,cosa,sina,factor

      CCTK_REAL, allocatable, dimension(:) :: xa,ya,za
      CCTK_REAL, allocatable, dimension(:) :: txx,tyy,tzz,txy,txz,tyz

      character(200) disf
      logical disf_exists

!     **************************
!     ***   DEFINE NUMBERS   ***
!     **************************

      zero  = 0.0D0
      half  = 0.5D0
      one   = 1.0D0
      two   = 2.0D0

      pi = acos(-one)

      factor = one


!     ****************************************
!     ***   FIND LINE CONNECTING CENTERS   ***
!     ****************************************

!     For the moment, horizons 1 and 2 only.

      write(*,*)
      write(*,*) 'Integrating distances between horizons 1 and 2 ...'

      x1 = ahf_xc_1
      y1 = ahf_yc_1
      z1 = ahf_zc_1

      x2 = ahf_xc_2
      y2 = ahf_yc_2
      z2 = ahf_zc_2

!     Find line connecting centers.

!     Neither horizon exists.

      if ((.not.status_old_1).and.(.not.status_old_2)) then

         write(*,*)
         write(*,*) 'Neither horizon 1 nor horizon 2 exist,'
         write(*,*) 'giving up.'
         write(*,*)

         d12 = zero
         goto 100

!     Just horizon 1 exists.

      else if (status_old_1.and.(.not.status_old_2)) then

         write(*,*)
         write(*,*) 'Only horizon 1 exists.'
         write(*,*)

!        Check symmetries.

         if (CCTK_Equals(domain,"octant").eq.1) then

            write(*,*) 'Octant symmetry: calculating twice'
            write(*,*) 'twice the distance from horizon 1 to origin.'

            factor = two

            x2 = zero
            y2 = zero
            z2 = zero

         else if (CCTK_Equals(domain,"quadrant").eq.1) then

            if (CCTK_Equals(quadrant_direction,"x").eq.1) then

               write(*,*) 'Quadrant symmetry, x direction: calculating'
               write(*,*) 'twice the distance from horizon 1 to x axis.'

               factor = two

               x2 = x1
               y2 = zero
               z2 = zero

            else if (CCTK_Equals(quadrant_direction,"y").eq.1) then

               write(*,*) 'Quadrant symmetry, y direction: calculating'
               write(*,*) 'twice the distance from horizon 1 to y axis.'

               factor = two

               x2 = zero
               y2 = y1
               z2 = zero

            else if (CCTK_Equals(quadrant_direction,"z").eq.1) then

               write(*,*) 'Quadrant symmetry, z direction: calculating'
               write(*,*) 'twice the distance from horizon 1 to z axis.'

               factor = two

               x2 = zero
               y2 = zero
               z2 = z1

            end if

         else if (CCTK_Equals(domain,"bitant").eq.1) then

            if (CCTK_Equals(bitant_plane,"xy").eq.1) then

               write(*,*) 'Bitant symmetry, xy plane: calculating twice'
               write(*,*) 'the distance from horizon 1 to xy plane.'

               factor = two

               x2 = x1
               y2 = y1
               z2 = zero

            else if (CCTK_Equals(bitant_plane,"xz").eq.1) then

               write(*,*) 'Bitant symmetry, xz plane: calculating twice'
               write(*,*) 'the distance from horizon 1 to xz plane.'

               factor = two

               x2 = x1
               y2 = zero
               z2 = z1

            else if (CCTK_Equals(bitant_plane,"yz").eq.1) then

               write(*,*) 'Bitant symmetry, yz plane: calculating twice'
               write(*,*) 'the distance from horizon 1 to yz plane.'

               factor = two

               x2 = zero
               y2 = y1
               z2 = z1

            end if

         else

            write(*,*) 'No grid symmetries: no distance to calculate,'
            write(*,*) 'giving up.'

            d12 = zero
            goto 100

         end if

!     Just horizon 2 exists.

      else if (status_old_2.and.(.not.status_old_1)) then

         write(*,*)
         write(*,*) 'Only horizon 2 exists.'
         write(*,*)

!        Check symmetries.

         if (CCTK_Equals(domain,"octant").eq.1) then

            write(*,*) 'Octant symmetry: calculating'
            write(*,*) 'twice the distance from horizon 2 to origin.'

            factor = two

            x1 = zero
            y1 = zero
            z1 = zero

         else if (CCTK_Equals(domain,"quadrant").eq.1) then

            if (CCTK_Equals(quadrant_direction,"x").eq.1) then

               write(*,*) 'Quadrant symmetry, x direction: calculating'
               write(*,*) 'twice the distance from horizon 2 to x axis.'

               factor = two

               x1 = x2
               y1 = zero
               z1 = zero

            else if (CCTK_Equals(quadrant_direction,"y").eq.1) then

               write(*,*) 'Quadrant symmetry, y direction: calculating'
               write(*,*) 'twice the distance from horizon 2 to y axis.'

               factor = two

               x1 = zero
               y1 = y2
               z1 = zero

            else if (CCTK_Equals(quadrant_direction,"z").eq.1) then

               write(*,*) 'Quadrant symmetry, z direction: calculating'
               write(*,*) 'twice the distance from horizon 2 to z axis.'

               factor = two

               x1 = zero
               y1 = zero
               z1 = z2

            end if

         else if (CCTK_Equals(domain,"bitant").eq.1) then

            if (CCTK_Equals(bitant_plane,"xy").eq.1) then

               write(*,*) 'Bitant symmetry, xy plane: calculating twice'
               write(*,*) 'the distance from horizon 2 to xy plane.'

               factor = two

               x1 = x2
               y1 = y2
               z1 = zero

            else if (CCTK_Equals(bitant_plane,"xz").eq.1) then

               write(*,*) 'Bitant symmetry, xz plane: calculating twice'
               write(*,*) 'the distance from horizon 2 to xz plane.'

               factor = two

               x1 = x2
               y1 = zero
               z1 = z2

            else if (CCTK_Equals(bitant_plane,"yz").eq.1) then

               write(*,*) 'Bitant symmetry, yz plane: calculating twice'
               write(*,*) 'the distance from horizon 2 to yz plane.'

               factor = two

               x1 = zero
               y1 = y2
               z1 = z2

            end if

         else

            write(*,*) 'No grid symmetries: no distance to calculate.'
            write(*,*) 'giving up.'

            d12 = zero
            goto 100

         end if

      end if

!     Find connecting line.

      x12 = x2 - x1
      y12 = y2 - y1
      z12 = z2 - z1

      rho12 = sqrt(x12**2 + y12**2)
      r12   = sqrt(x12**2 + y12**2 + z12**2)


!     ***********************************************************
!     ***   FIND LOCATION OF HORIZONS ALONG CONNECTING LINE   ***
!     ***********************************************************

!     Find angles for horizon 1.

      if (r12.ne.zero) then
         cost = z12/r12
      else
         write(*,*)
         write(*,*) 'Coordinate distance is zero,'
         write(*,*) 'giving up.'
         write(*,*)
         d12 = zero
         goto 100
      end if

      sint = sqrt(one - cost**2)

      if (y12.ne.zero) then
         phi = atan2(y12,x12)
      else
         phi = zero
      end if

      sinp = sin(phi)
      cosp = cos(phi)

!     Find point in horizon 1.

      if (status_old_1) then

         r1 = c0(0)

         do l=1+stepz,lmax,1+stepz
            r1 = r1 + c0(l)*LEGEN(l,0,cost)
         end do

         if (nonaxi) then
            do m=1,lmax
               aux = dble(m)*phi
               sina = sin(aux)
               cosa = cos(aux)
               do l=m,lmax
                  aux = LEGEN(l,m,cost)
                  r1 = r1 + aux*cc(l,m)*cosa
                  if (.not.refy) then
                     r1 = r1 + aux*cs(l,m)*sina
                  end if
               end do
           end do
         end if

         x1 = x1 + r1*sint*cosp
         y1 = y1 + r1*sint*sinp
         z1 = z1 + r1*cost

      end if

!     Find angles for horizon 2.

      cost = -cost
      sint = +sint

      cosp = -cosp
      sinp = -sinp

      phi = phi + pi

!     Find point in horizon 2.

      if (status_old_2) then

         r2 = c0(0)

         do l=1+stepz,lmax,1+stepz
            r2 = r2 + c0(l)*LEGEN(l,0,cost)
         end do

         if (nonaxi) then
            do m=1,lmax
               aux = dble(m)*phi
               sina = sin(aux)
               cosa = cos(aux)
               do l=m,lmax
                  aux = LEGEN(l,m,cost)
                  r2 = r2 + aux*cc(l,m)*cosa
                  if (.not.refy) then
                     r2 = r2 + aux*cs(l,m)*sina
                  end if
               end do
            end do
         end if

         x2 = x2 + r2*sint*cosp
         y2 = y2 + r2*sint*sinp
         z2 = z2 + r2*cost

      end if


!     **************************************
!     ***   ALLOCATE MEMORY FOR ARRAYS   ***
!     **************************************

      aux = sqrt((x1-x2)**2 + (y1-y2)**2 + (z1-z2)**2)/dx

      np = int(aux)

      if (myproc.eq.0) then

         allocate(xa(0:np))
         allocate(ya(0:np))
         allocate(za(0:np))

         allocate(txx(0:np))
         allocate(tyy(0:np))
         allocate(tzz(0:np))
         allocate(txy(0:np))
         allocate(txz(0:np))
         allocate(tyz(0:np))

      else

         allocate(xa(1))
         allocate(ya(1))
         allocate(za(1))

         allocate(txx(1))
         allocate(tyy(1))
         allocate(tzz(1))
         allocate(txy(1))
         allocate(txz(1))
         allocate(tyz(1))

      end if


!     *************************************
!     ***   FIND INTERPOLATING POINTS   ***
!     *************************************

      if (myproc.eq.0) then

         npoints = np + 1

         do i=0,np

            aux = dble(i)/dble(np)

            xa(i) = x1 + aux*(x2-x1)
            ya(i) = y1 + aux*(y2-y1)
            za(i) = z1 + aux*(z2-z1)

         end do

      else

         npoints = 1

         xa = half*(x1 + x2)
         ya = half*(y1 + y2)
         za = half*(z1 + z2)

      end if


!     ******************************
!     ***   INTERPOLATE METRIC   ***
!     ******************************

!     parameter, local interpolator, and coordinate system handle.
      param_table_handle = -1
      interp_handle = -1
      coord_system_handle = -1

      options_string = "order = " // char(ichar('0') + interpolation_order)
      call Util_TableCreateFromString (param_table_handle, options_string)
      if (param_table_handle .lt. 0) then
        call CCTK_WARN(0,"Cannot create parameter table for interpolator")
      endif

      call CCTK_FortranString (nchars, interpolation_operator, operator)
      call CCTK_InterpHandle (interp_handle, operator)
      if (interp_handle.lt.0) then
        call CCTK_WARN(0,"Cannot get handle for interpolation ! Forgot to activate an implementation providing interpolation operators ??")
      endif

      call CCTK_CoordSystemHandle (coord_system_handle, "cart3d")
      if (coord_system_handle .lt. 0) then
        call CCTK_WARN(0,"Cannot get handle for cart3d coordinate system ! Forgot to activate an implementation providing coordinates ??")
      endif


!     fill in the input/output arrays for the interpolator
      interp_coords(1) = CCTK_PointerTo(xa)
      interp_coords(2) = CCTK_PointerTo(ya)
      interp_coords(3) = CCTK_PointerTo(za)

      call CCTK_VarIndex (vindex, "admbase::gxx")
      in_array_indices(1) = vindex
      call CCTK_VarIndex (vindex, "admbase::gyy")
      in_array_indices(2) = vindex
      call CCTK_VarIndex (vindex, "admbase::gzz")
      in_array_indices(3) = vindex
      call CCTK_VarIndex (vindex, "admbase::gxy")
      in_array_indices(4) = vindex
      call CCTK_VarIndex (vindex, "admbase::gxz")
      in_array_indices(5) = vindex
      call CCTK_VarIndex (vindex, "admbase::gyz")
      in_array_indices(6) = vindex

      out_arrays(1) = CCTK_PointerTo(txx)
      out_arrays(2) = CCTK_PointerTo(tyy)
      out_arrays(3) = CCTK_PointerTo(tzz)
      out_arrays(4) = CCTK_PointerTo(txy)
      out_arrays(5) = CCTK_PointerTo(txz)
      out_arrays(6) = CCTK_PointerTo(tyz)

      out_array_type_codes = CCTK_VARIABLE_REAL


!     Interpolation.

      call CCTK_InterpGridArrays (ierror, cctkGH, 3, interp_handle,
     .                            param_table_handle, coord_system_handle,
     .                            npoints, CCTK_VARIABLE_REAL, interp_coords,
     .                            6, in_array_indices,
     .                            6, out_array_type_codes, out_arrays)
      if (ierror < 0) then
        call CCTK_WARN (1, "interpolator call returned an error code");
      endif

!     release parameter table
      call Util_TableDestroy (ierror, param_table_handle)


!     ******************************
!     ***   INTEGRATE DISTANCE   ***
!     ******************************

      ddx = (x2-x1)/dble(np)
      ddy = (y2-y1)/dble(np)
      ddz = (z2-z1)/dble(np)

      if (myproc.eq.0) then

!        Integrate using trapezoidal rule.

         d12 = zero

         do i=1,np

            d12 = d12 + half
     .          *(sqrt(txx(i-1)*ddx**2  + tyy(i-1)*ddy**2  + tzz(i-1)*ddz**2
     .          +  two*(txy(i-1)*ddx*ddy + txz(i-1)*ddx*ddz + tyz(i-1)*ddy*ddz))
     .          + sqrt(txx(i  )*ddx**2  + tyy(i  )*ddy**2  + tzz(i  )*ddz**2
     .          +  two*(txy(i  )*ddx*ddy + txz(i  )*ddx*ddz + tyz(i  )*ddy*ddz)))

         end do

      end if

      d12 = factor*d12


!     *****************************
!     ***   DEALLOCATE MEMORY   ***
!     *****************************

      deallocate(xa,ya,za)
      deallocate(txx,tyy,tzz,txy,txz,tyz)


!     ******************
!     ***   OUTPUT   ***
!     ******************

  100 continue

      disf = filestr(1:nfile) // "/ahf_d12" // ".tl"
      if (myproc.eq.0) then
        inquire(file=disf, exist=disf_exists)
        if (disf_exists) then
          open(11,file=disf,form='formatted',status='old', position='append')
        else
          open(11,file=disf,form='formatted',status='replace')
          write(11,"(A18)") '" Horizon distance'
        end if
        write(11,"(2ES14.6)") cctk_time,d12
        close(11)
      end if


!     ***************
!     ***   END   ***
!     ***************

      end subroutine AHFinder_dis

```

AHFinder.F:
```
/*@@
  @file      AHFinder.F
  @date      April 1998
  @author    Miguel Alcubierre
  @desc
             Find an apparent horizon using a spherical harmonic
             expansion and either a minimization or Gundlach's
             fast flow algorithm.

             Cactus4 by Lars Nerger / Gerd Lanfermann
  @enddesc
  @version   $Header$
@@*/

#include "cctk.h"

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

      subroutine AHFinder(CCTK_ARGUMENTS)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS
      DECLARE_CCTK_FUNCTIONS

      CCTK_INT, parameter :: izero = 0
      integer,  parameter :: ik = kind(izero)

      logical status,horizon,ahfconformal
      logical giveup,report

      integer ahfso,ahfafter
      integer i,l,m
      integer NN
      integer mtype
      integer nhorizon

      CCTK_REAL atime
      CCTK_REAL rmx,r0
      CCTK_REAL intexp_h,intexp2_h,intarea_h
      CCTK_REAL aux,expin,expout,small1,small2
      CCTK_REAL c0_temp(0:18)
      CCTK_REAL rhor

      CCTK_REAL, parameter :: zero = 0.0D0
      CCTK_REAL, parameter :: half = 0.5D0
      CCTK_REAL, parameter :: one  = 1.0D0

      CCTK_REAL, dimension (1:3) :: ahfmass
      CCTK_INT :: save_conformal_state

      character(200) logf

      save ahfafter,ahfso,atime

!     Description of variables:
!
!     status    Surface found?
!
!     horizon   Horizon found?
!
!     gauss     Output Gaussian curvature?
!
!     ahfso     How often we want to find a horizon?
!     ahfafter  After how many iterations start looking for horizons?
!
!     i,l,m     Counters.
!
!     NN        Total number of terms in expansion.
!
!     rmx       Radius of largest sphere that fits in the grid.
!
!     mtype     Type of surface:
!                  0.  No surface found.
!                  1.  Integral of H^2 is positive out and negative in.
!                  2.  Integral of H^2 is negative out and positive in.
!                  3.  Integral of H^2 is negative out and in.
!                  4.  Integral of H^2 is positive out and in.
!
!     nhorizon  Number of horizons to look for.


!     ***************************
!     ***   INITIALIZE MASK   ***
!     ***************************

!     Initialize mask to one, but only on first iteration.
!     Notice that I do this even if we do not want to find
!     a horizon from the very beginning.  This is to make
!     sure that the mask is 1 and not 0 in case some other
!     thorn wants to use it.

      if (cctk_iteration.eq.0 .or. CCTK_EQUALS(ahf_mask, "off")) then
         ahmask = one
      end if


!     ***********************************************************
!     ***   CHECK IF WE WANT TO FIND A HORIZON AT THIS TIME   ***
!     ***********************************************************

      atime = ahf_findaftertime

      if (atime.le.zero) then
         ahfafter = ahf_findafter
         if (cctk_iteration.lt.ahfafter) return
      else
         if (cctk_time.lt.atime) return
         if (ahf_ncall.eq.0) ahfafter = cctk_iteration
      end if

      ahfso = ahf_findevery
      if (mod(int(cctk_iteration-ahfafter),ahfso).ne.0) return


!     *******************************************
!     ***   ADD TO COUNT OF CALLS TO FINDER   ***
!     *******************************************

!     Add to count of calls to finder.  Notice that this counter was
!     initialized to zero, so it must be increased on first call to 1.

      ahf_ncall = ahf_ncall + 1


!     *********************************************************
!     ***   FIND OUT IF WE WANT TO FIND A TRAPPED SURFACE   ***
!     *********************************************************

      if (ahf_trapped_surface.ne.0) then
         find_trapped_surface = .true.
      else
         find_trapped_surface = .false.
      end if


!     ***************************
!     ***   GRID PARAMETERS   ***
!     ***************************

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

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


!     *********************************************
!     ***   SET SYMMETRIES FOR GRID FUNCTIONS   ***
!     *********************************************

      call AHFinder_SetSym(CCTK_ARGUMENTS)


!     **********************************************
!     ***   FIND OUT ON WHICH PROCESSOR WE ARE   ***
!     **********************************************

      myproc = CCTK_MyProc(cctkGH)


!     *******************************************
!     ***   FIND  {xmn,xmx,ymn,ymx,zmn,zmx}   ***
!     *******************************************

      call CCTK_CoordRange(ierr,cctkGH,xmn,xmx,-1,"x","cart3d")
      call CCTK_CoordRange(ierr,cctkGH,ymn,ymx,-1,"y","cart3d")
      call CCTK_CoordRange(ierr,cctkGH,zmn,zmx,-1,"z","cart3d")


!     **************************************************
!     ***   TRANSFORM CONFORMAL TO PHYSICAL METRIC   ***
!     **************************************************

      ahfconformal = .false.

!     The horizon finding routines know nothing about conformal
!     metrics, so we need to make sure that we are working with
!     the physical metric.  I change not only the metric, but
!     also the "conformal state" flag to make sure that any
!     macros I use have always the physical metric.  However,
!     I need to remember the original value of the flag to change
!     it back at the end if necesary.

      if ( CCTK_Equals(metric_type,"static conformal") == 1 ) then
         ahfconformal    = .true.
         save_conformal_state = conformal_state
         conformal_state = 0

         call ConfToPhysInPlace (int(nx,ik),int(ny,ik),int(nz,ik),psi,
     &        gxx,gxy,gxz,gyy,gyz,gzz)

      end if


!     ************************
!     ***   FIND  {lmax}   ***
!     ************************

      lmax = ahf_lmax

      if (lmax.ge.20) then
         write(*,*)
         write(*,*) 'ahf_lmax must be smaller than 20.'
         write(*,*) 'STOPPED IN AHFinder.F'
         write(*,*)
         call CCTK_WARN(0,"ahf_lmax must be smaller than 20.")
      end if


!     ***********************************************
!     ***   CHECK IF WE WANT TO FIND 3 HORIZONS   ***
!     ***********************************************

      if (ahf_find3.eq.0) then
         find3 = .false.
         nhorizon = 1
      else
         find3 = .true.
         nhorizon = 3
      end if


!     ***************************************************
!     ***   ALLOCATE STORAGE FOR COEFFICIENT ARRAYS   ***
!     ***************************************************

      if (ahf_ncall.eq.1) then

         allocate(c0(0:lmax),c0_old(0:lmax))
         allocate(cc(lmax,lmax),cc_old(lmax,lmax))
         allocate(cs(lmax,lmax),cs_old(lmax,lmax))

         c0 = zero
         cc = zero
         cs = zero

         c0_old = zero
         cc_old = zero
         cs_old = zero

         allocate(c0_0(0:lmax),c0_1(0:lmax),c0_2(0:lmax))
         allocate(cc_0(lmax,lmax),cc_1(lmax,lmax),cc_2(lmax,lmax))
         allocate(cs_0(lmax,lmax),cs_1(lmax,lmax),cs_2(lmax,lmax))

         c0_0 = zero
         cc_0 = zero
         cs_0 = zero

         c0_1 = zero
         cc_1 = zero
         cs_1 = zero

         c0_2 = zero
         cc_2 = zero
         cs_2 = zero

      end if

!     ***************************************************
!     ***   START LOOP TO LOOK FOR SEVERAL HORIZONS   ***
!     ***************************************************

!     IMPORTANT:  This is the point where we start the loop
!     to look for more than one horizon. Because of this,
!     anything that is likely to be different for the different
!     horizons should NOT be initialized until after this point!

      ahfmass = 0.0D0

      do mfind=1,nhorizon

!     Say what we are doing.

      if (nhorizon.gt.1) then
         if (mfind.eq.1) then
            write(*,*)
            write(*,*)
            write(*,*) 'AHFinder: MULTIPLE HORIZON MODE!'
         end if
         write(*,*)
         write(*,*) 'Searching for horizon ',mfind-1
      else
         write(*,*)
         write(*,*)
         write(*,*) 'AHFinder: SINGLE HORIZON MODE!'
         write(*,*)
         write(*,*) 'Searching for horizon'
      end if


!     ********************************
!     ***   INITIALIZE  {status}   ***
!     ********************************

      status = .false.


!     *********************************
!     ***   INITIALIZE FIRSTCALLS   ***
!     *********************************

      firstleg = .true.
      firstint = .true.


!     ***************************************
!     ***   FIND OUT THE TYPE OF OUTPUT   ***
!     ***************************************

      call CCTK_FortranString(nfile,out_dir,filestr)
      if (ahf_logfile.ne.0) then
         logfile = .true.
         logf = filestr(1:nfile)//"/ahf_logfile"
         if (find3) then
            logf = trim(logf) // "_" // char(ichar('0') + mfind - 1)
         end if
      else
         logfile = .false.
      end if

      if (ahf_verbose.ne.0) then
         verbose = .true.
      else
         verbose = .false.
      end if

      if (ahf_veryverbose.ne.0) then
         veryver = .true.
      else
         veryver = .false.
      end if

      if (ahf_guessverbose.ne.0) then
         guessverbose = .true.
      else
         guessverbose = .false.
      end if

      if (logfile.and.(myproc.eq.0)) then
         if (logfile) then
            if (myproc.eq.0) then
               open(11,file=logf,form='formatted',status='replace')
               write(11,*)
               write(11,*) 'LOG FILE FOR APPARENT HORIZON FINDER'
               write(11,*)
               write(11,*) 'Note:  During an evolution, this file will only'
               write(11,*) 'contain information about the last time that the'
               write(11,*) 'finder was called.'
               write(11,*)
               close(11)
            end if
         end if
      end if


!     **********************************
!     ***   INITIALIZE  {xc,yc,zc}   ***
!     **********************************

      if (find3) then
         if (mfind.eq.1) then
            xc = ahf_xc_0
            yc = ahf_yc_0
            zc = ahf_zc_0
         else if (mfind.eq.2) then
            xc = ahf_xc_1
            yc = ahf_yc_1
            zc = ahf_zc_1
         else
            xc = ahf_xc_2
            yc = ahf_yc_2
            zc = ahf_zc_2
         end if
      else
         xc = ahf_xc
         yc = ahf_yc
         zc = ahf_zc
      end if

!     Check if the center of the expansion is
!     out of the grid.  If it is, give up.

      giveup = .false.

      if ((xc.gt.xmx).or.(xc.lt.xmn)) then
         write(*,*)
         write(*,*) 'xc is out of the grid, giving up.'
         giveup = .true.
      end if

      if ((yc.gt.ymx).or.(yc.lt.ymn)) then
         write(*,*)
         write(*,*) 'yc is out of the grid, giving up.'
         giveup = .true.
      end if

      if ((zc.gt.zmx).or.(zc.lt.zmn)) then
         write(*,*)
         write(*,*) 'zc is out of the grid, giving up.'
         giveup = .true.
      end if

!     The end of this if statement is very far down,
!     it basically jumps all of the code.  To find
!     it look for the word "giveup" on a comment.

      if (.not.giveup) then


!     **************************
!     ***  FIND SYMMETRIES   ***
!     **************************

!     Find out if we want to move the center.

      if (ahf_offset.ne.0) then
         offset = .true.
      else
         offset = .false.
      end if

      if (ahf_wander.ne.0) then
         wander = .true.
      else
         wander = .false.
      end if

      if ((xc.ne.zero).or.(yc.ne.zero).or.(zc.ne.zero).or.
     .    (wander)) offset = .true.

!     Find out if we are in non-axisymmetric mode.

      if (ahf_phi.ne.0) then
         nonaxi = .true.
      else
         nonaxi = .false.
      end if


      call AHFinder_SetReflections(CCTK_ARGUMENTS)

!     Find the values of {stepx,stepy,stepz} depending
!     on the symmetries.

      stepx = 0
      stepy = 0
      stepz = 0

      if (refx) stepx=1
      if (refy) stepy=1
      if (refz) stepz=1

      if (CCTK_Equals(ahf_octant,"high").eq.1) stepx=3


!     *******************************
!     ***   FIND  {ntheta,nphi}   ***
!     *******************************

      ntheta = ahf_ntheta
      nphi   = ahf_nphi

!     For cartoon, I use only 2 points in the phi direction.
!     I could use one, but using 2 minimizes the changes in
!     the integration routine.

      if (cartoon) then
         nphi = 1
      end if


!     ********************************************************
!     ***   FIND TOTAL NUMBER OF TERMS IN EXPANSION {NN}   ***
!     ********************************************************

      NN = 0

!     Count {xc,yc,zc}.

      if (wander) then
         if (.not.refx) NN = NN + 1
         if (.not.refy) NN = NN + 1
         if (.not.refz) NN = NN + 1
      end if

!     Count c0(l).

      do l=0,lmax,1+stepz
         NN = NN + 1
      end do

      if (nonaxi) then

!        Count cc(l,m).

         do l=1,lmax
            do m=1+stepx,l,1+stepx
               if (stepz*mod(l-m,2).eq.0) NN = NN +1
            end do
         end do

!        Count cs(l,m).

         if (.not.refy) then
            do l=1,lmax
               do m=1,l,1+stepx
                  if (stepz*mod(l-m,2).eq.0) NN = NN + 1
               end do
            end do
         end if

      end if


!     *****************************************
!     ***   FIND RADIUS OF INITIAL SPHERE   ***
!     *****************************************

!     Find largest sphere that fits into the grid, taking
!     into account the position of the center.  Then multiply
!     this number with 0.9 to leave a safety margin at the edge
!     of the grid.

!     Cartoon.

      if (cartoon) then

         xc = zero
         yc = zero

         rmx = min(xmx,zmx-zc,zc-zmn)

!     Octant.

      else if (CCTK_Equals(domain,"octant").eq.1) then

         if ((xc.eq.zero).and.(yc.eq.zero).and.(zc.eq.zero)) then
            rmx = min(xmx,ymx,zmx)
         else if ((xc.eq.zero).and.(yc.eq.zero)) then
            rmx = min(xmx,ymx,zmx-zc,zc)
         else if ((xc.eq.zero).and.(zc.eq.zero)) then
            rmx = min(xmx,ymx-yc,zmx,yc)
         else if ((yc.eq.zero).and.(zc.eq.zero)) then
            rmx = min(xmx-xc,ymx,zmx,xc)
         else if (xc.eq.zero) then
            rmx = min(xmx,ymx-yc,zmx-zc,yc,zc)
         else if (yc.eq.zero) then
            rmx = min(xmx-xc,ymx,zmx-zc,xc,zc)
         else if (zc.eq.zero) then
            rmx = min(xmx-xc,ymx-yc,zmx,xc,yc)
         else
            rmx = min(xmx-xc,ymx-yc,zmx-zc,xc,yc,zc)
         end if

!     Quadrant.

      else if (CCTK_Equals(domain,"quadrant").eq.1) then
         if ((xc.eq.zero).and.(yc.eq.zero)) then
            rmx = min(xmx,ymx,zmx-zc,zc-zmn)
         else if (xc.eq.zero) then
            rmx = min(xmx,ymx-yc,zmx-zc,yc,zc-zmn)
         else if (yc.eq.zero) then
            rmx = min(xmx-xc,ymx,zmx-zc,xc,zc-zmn)
         else
            rmx = min(xmx-xc,ymx-yc,zmx-zc,xc,yc,zc-zmn)
         end if

!     Bitant.

      else if (CCTK_Equals(domain,"bitant").eq.1) then

         if (CCTK_Equals(bitant_plane,"xy").eq.1) then

            if (zc.eq.zero) then
               rmx = min(xmx-xc,ymx-yc,xc-xmn,yc-ymn,zmx)
            else
               rmx = min(xmx-xc,ymx-yc,xc-xmn,yc-ymn,zmx-zc,zc)
            end if

         else if (CCTK_Equals(bitant_plane,"xz").eq.1) then

            if (yc.eq.zero) then
               rmx = min(xmx-xc,zmx-zc,xc-xmn,zc-zmn,ymx)
            else
               rmx = min(xmx-xc,zmx-zc,xc-xmn,zc-zmn,ymx-yc,yc)
            end if

         else

            if (xc.eq.zero) then
               rmx = min(ymx-yc,zmx-zc,yc-ymn,zc-zmn,xmx)
            else
               rmx = min(ymx-yc,zmx-zc,yc-ymn,zc-zmn,xmx-xc,xc)
            end if

         end if

!     Full.

      else

         rmx = min(xmx-xc,ymx-yc,zmx-zc,xc-xmn,yc-ymn,zc-zmn)

      end if

      rmx = 0.9*rmx

!     Check if a special radius for the initial sphere
!     has been forced by the parameter file.

      if (find3) then
         if (mfind.eq.1) then
            r0 = ahf_r0_0
         else if (mfind.eq.2) then
            r0 = ahf_r0_1
         else
            r0 = ahf_r0_2
         end if
      else
         r0 = ahf_r0
      end if

      if (r0.ne.zero) then
         if (r0.le.rmx) then
            rmx = r0
         else
            write (*,*)
            write (*,*) 'ahf_r0 is too large, rescaling ...'
         end if
      end if


!     *****************************
!     ***   GET INITIAL GUESS   ***
!     *****************************

!     Initializing flags

      sloppy = (ahf_sloppyguess.eq.1)

      if (cartoon) sloppy = .true.

      flow = (ahf_flow.eq.1)

      inner = (ahf_inner.eq.1)

      if (ahf_guessold.ne.0) then
         guessold = .true.
      else
         guessold = .false.
      end if

      if (ahf_guess_absmin.ne.0) then
         guess_absmin = .true.
      else
         guess_absmin = .false.
      end if

      if (ahf_manual_guess.ne.0) then
         manual_guess = .true.
      else
         manual_guess = .false.
      end if

      if (ahf_minarea.ne.0) then
         minarea = .true.
      else
         minarea = .false.
      end if

!     Get initial guess.

      if (find3) then
         if (mfind.eq.1) then
            status_old = status_old_0
         else if (mfind.eq.2) then
            status_old = status_old_1
         else
            status_old = status_old_2
         end if
      end if

      if (guessold.and.status_old) then

!        Old horizon as initial guess.

         if ((myproc.eq.0).and.verbose) then
            write(*,*)
            write(*,*)  'Using old horizon as initial guess'
         end if

!        If we are only looking for 1 horizon, then we are OK
!        since the arrays (c0,cc,cs) where saved from the last
!        call.  If we are looking for 3 horizons, we saved all
!        3 sets of coefficients, but now we need to copy them
!        back to the right place.

         if (find3) then
            if (mfind.eq.1) then
               c0 = c0_0
               cc = cc_0
               cs = cs_0
            else if (mfind.eq.2) then
               c0 = c0_1
               cc = cc_1
               cs = cs_1
            else
               c0 = c0_2
               cc = cc_2
               cs = cs_2
            end if
         end if

      else if (manual_guess) then

!        Manual guess.

         if ((myproc.eq.0).and.verbose) then
            write(*,*)
            write(*,*)  'Using manual initial guess'
         end if

         c0_temp(0) = ahf_l0_guess
         c0_temp(2) = ahf_l2_guess
         c0_temp(4) = ahf_l4_guess
         c0_temp(6) = ahf_l6_guess
         c0_temp(8) = ahf_l8_guess
         c0_temp(10) = ahf_l10_guess
         c0_temp(12) = ahf_l12_guess
         c0_temp(14) = ahf_l14_guess
         c0_temp(16) = ahf_l16_guess
         c0_temp(18) = ahf_l18_guess

         if (lmax.le.18) then
            do i=0,lmax
               c0(i) = c0_temp(i)
            end do
         else
            do i=0,18
               c0(i) = c0_temp(i)
            end do
         end if

      else

!        Standard initial guess.

         if (.not.flow) then

!           For minimization, call initial guess routine.

            call AHFinder_initguess(CCTK_ARGUMENTS,rmx)

         else

!           For flow, take as initial guess a large sphere.

            c0 = zero
            cc = zero
            cs = zero

            c0_old = zero
            cc_old = zero
            cs_old = zero

            if ((myproc.eq.0).and.verbose) then
               write(*,*)
               write(*,"(A35,ES11.3)")  ' Initial guess sphere with radius: ',rmx
               write(*,"(A13,3ES11.3)") ' centered on:',real(xc),real(yc),real(zc)
            end if

            c0(0) = rmx

         end if

      end if


!     ***************************
!     ***   LOOK FOR HORIZON  ***
!     ***************************

      if (.not.flow) then

!        Minimization algorithm.

         call AHFinder_min(CCTK_ARGUMENTS,NN,status,logf)

      else

!        Flow algorithm.

         if ((ahf_ncall.eq.1).and.(mfind.eq.1)) then
            allocate(hflow0(0:lmax),cflow0(0:lmax),nflow0(0:lmax))
            allocate(hflowc(lmax,lmax),cflowc(lmax,lmax),nflowc(lmax,lmax))
            allocate(hflows(lmax,lmax),cflows(lmax,lmax),nflows(lmax,lmax))
         end if

         call AHFinder_flow(CCTK_ARGUMENTS,rmx,status,logf)
         flow = .false.

      end if


!     ***************************************
!     ***   WRITE MESSAGES AND LOG FILE   ***
!     ***************************************

      if (find3) then
         if (mfind.eq.1) then
            status_old_0 = status
         else if (mfind.eq.2) then
            status_old_1 = status
         else
            status_old_2 = status
         end if
      else
         status_old = status
      end if

      if (status) then

!        Check if the expansion on the surface is small enough
!        for a horizon.  How small is small enough is of course
!        pretty arbitrary, so to reduce the subjectivity I use
!        three separate criteria:
!
!        1) The integral of the square of the expansion at the surface
!           must be smaller than a given threshold (small1).
!
!        2) The mean value of the expansion on the surface must be
!           smaller in absolute value than its standard deviation.
!           This means that the mean value of the expansion is
!           consistent with zero.
!
!        3) The integral of the square of the expansion at the surface
!           must be smaller by a factor of "small2" than the same
!           integral slightly outside and slightly inside.

         horizon = .true.

         small1 = 1.0D-2
         small2 = 0.5D0

!        Surface found.

         call AHFinder_fun(CCTK_ARGUMENTS)
         call AHFinder_exp(CCTK_ARGUMENTS)
         call AHFinder_int(CCTK_ARGUMENTS)

         if (ahf_gaussout.ne.0) then
            call AHFinder_gau(CCTK_ARGUMENTS)
         else
            circ_eq = 0.0D0
            meri_p1 = 0.0D0
            meri_p2 = 0.0D0
         end if

         intexp_h  = intexp
         intexp2_h = intexp2
         intarea_h = intarea

         if (intexp2_h.gt.small1) horizon = .false.

!        Find standard deviation:  sqrt(<exp^2> - <exp>^2)
!        The term inside the parenthesis is supposed to be positive,
!        but may fail to be because of numerical errors in pathological
!        situations, so be careful.

         aux = intexp2_h/intarea_h - (intexp_h/intarea_h)**2

         if (aux.ge.zero) then
            aux = sqrt(aux)
            if (abs(intexp_h/intarea_h)-aux.gt.zero) horizon = .false.
         else
            horizon = .false.
         end if

!        Surface slightly inside

         aux = c0(0)

         c0(0) = aux - half*min(dx,dy,dz)
         call AHFinder_int(CCTK_ARGUMENTS)

         expin = intexp

         if (intexp2_h.gt.small2*intexp2) horizon = .false.

         if (veryver) then
            write(*,*)
            write(*,*) 'Surface slightly inside the minimum surface: '
            write(*,"(A21,ES14.6)") ' Integral of H      =',intexp
            write(*,"(A21,ES14.6)") ' Integral of H^2    =',intexp2
            write(*,"(A21,ES14.6)") ' Mean value of H    =',intexp/intarea
            write(*,"(A21,ES14.6)") ' Mean value of H^2  =',intexp2/intarea
            write(*,*) 'Number of interpolated points:     ',
     .         inside_min_count
            write(*,*) 'Number of those that are negative: ',
     .         inside_min_neg_count
         endif

!        Surface slightly outside.

         c0(0) = aux + half*min(dx,dy,dz)
         call AHFinder_int(CCTK_ARGUMENTS)

         expout = intexp

         if (intexp2_h.gt.small2*intexp2) horizon = .false.

         if (veryver) then
            write(*,*)
            write(*,*) 'Surface slightly outside the minimum surface: '
            write(*,"(A21,ES14.6)") ' Integral of H      =',intexp
            write(*,"(A21,ES14.6)") ' Integral of H^2    =',intexp2
            write(*,"(A21,ES14.6)") ' Mean value of H    =',intexp/intarea
            write(*,"(A21,ES14.6)") ' Mean value of H^2  =',intexp2/intarea
            write(*,*) 'Number of interpolated points:     ',
     .         inside_min_count
            write(*,*) 'Number of those that are negative: ',
     .         inside_min_neg_count
         endif

         c0(0) = aux

!        What kind of horizon?

         if ((expin.le.zero).and.(expout.ge.zero)) then
            mtype = 1
         else if ((expin.ge.zero).and.(expout.le.zero)) then
            mtype = 2
         else if ((expin.le.zero).and.(expout.le.zero)) then
            mtype = 3
         else
            mtype = 4
         end if

!        Messages to screen and logfile

         if (ahf_ReportAlways.eq.1) then
            report = .true.
         else
            report = mtype.eq.1
         end if

!        Report on the details of the surface.

         if (report.and.(myproc.eq.0)) then

!           Open logfile.

            if (logfile) then
               open(11,file=logf,form='formatted',
     .         status='old',position='append')
            end if

!           Find inverse of area.  Be carefull not to divide by zero!
!           Also, a value of 1.0D10 indicates an error in the integration
!           routine, and all integrals end up with the same value.
!           So do not divide by it or I will be confused later.

            if ((intarea_h.ne.zero).and.(intarea.lt.1.0D10)) then
               aux = one/intarea_h
            else
               aux = one
            end if

!           Surface information.  Notice that here I define the
!           surface "mass" as:
!
!           M = sqrt( A / (16 pi) ) = 0.141047396 sqrt(A)

            ahfmass(mfind) = 0.141047396D0*sqrt(intarea_h)

            write(*,*)
            write(*,*) 'Surface found, details below.'
            write(*,*)
            write(*,"(A21,ES14.6)") ' Surface area       =',intarea_h
            write(*,"(A21,ES14.6)") ' Surface mass       =',
     .      0.141047396D0*sqrt(intarea_h)
            write(*,"(A21,ES14.6)") ' Mean value of H    =',aux*intexp_h
            write(*,"(A21,ES14.6)") ' Mean value of H^2  =',aux*intexp2_h
            write(*,"(A21,ES14.6)") ' Standard deviation =',
     .      sqrt(abs(aux*intexp2_h - (aux*intexp_h)**2))
            write(*,*)
            if (ahf_gaussout.ne.0) then
               write(*,"(A11,ES14.6)") ' circ_eq  =',circ_eq
               write(*,"(A11,ES14.6)") ' meri_p1  =',meri_p1
               write(*,"(A11,ES14.6)") ' meri_p2  =',meri_p2
               write(*,*)
            end if

            if (logfile) then
               write(11,*)
               write(11,*) 'Surface found, details below'
               write(11,*)
               write(11,"(A21,ES14.6)") ' Surface area       =',intarea_h
               write(11,"(A21,ES14.6)") ' Surface mass       =',
     .         0.141047396D0*sqrt(intarea_h)
               write(11,"(A21,ES14.6)") ' Mean value of H    =',aux*intexp_h
               write(11,"(A21,ES14.6)") ' Mean value of H^2  =',aux*intexp2_h
               write(11,"(A21,ES14.6)") ' Standard deviation =',
     .         sqrt(abs(aux*intexp2_h - (aux*intexp_h)**2))
               write(11,*)
               if (ahf_gaussout.ne.0) then
                  write(11,"(A11,ES14.6)") ' circ_eq  =',circ_eq
                  write(11,"(A11,ES14.6)") ' meri_p1  =',meri_p1
                  write(11,"(A11,ES14.6)") ' meri_p2  =',meri_p2
                  write(11,*)
               end if
            end if

            if (mtype.eq.1) then
               if (horizon) then
                 write(*,*) 'The surface seems to be an outer horizon.'
                 if (logfile) then
                    write(11,*) 'The surface seems to be an outer horizon.'
                 end if
               else
                 write(*,*) 'The surface is probably an outer horizon, but'
                 write(*,*) 'the mean of the square of the expansion is'
                 write(*,*) 'not small enough. Try a larger lmax, or a'
                 write(*,*) 'smaller grid size.'
                 if (logfile) then
                    write(11,*) 'The surface is probably an outer horizon, but'
                    write(11,*) 'the mean of the square of the expansion is'
                    write(11,*) 'not small enough. Try a larger lmax, or a'
                    write(11,*) 'smaller grid size.'
                 end if
               end if
            else if (mtype.eq.2) then
               if (horizon) then
                 write(*,*) 'The surface seems to be an inner horizon.'
                 if (logfile) then
                    write(11,*) 'The surface seems to be an inner horizon.'
                 end if
               else
                 write(*,*) 'The surface is probably an inner horizon, but'
                 write(*,*) 'the mean of the square of the expansion is'
                 write(*,*) 'not small enough. Try a larger lmax, or a'
                 write(*,*) 'smaller grid size.'
                 if (logfile) then
                    write(11,*) 'The surface is probably an inner horizon, but'
                    write(11,*) 'the mean of the square of the expansion is'
                    write(11,*) 'not small enough. Try a larger lmax, or a'
                    write(11,*) 'smaller grid size.'
                 end if
               end if
            else if (mtype.eq.3)then
               if (horizon) then
                 write(*,*) 'The surface seems to be a marginal horizon'
                 write(*,*) '(the integral of the expansion is negative'
                 write(*,*) 'on both sides.)'
                 if (logfile) then
                    write(11,*) 'The surface seems to be a marginal horizon'
                    write(11,*) '(the integral of the expansion is negative'
                    write(11,*) 'on both sides.)'
                 end if
               else
                 write(*,*) 'The surface seems to be a trapped surface.'
                 if (logfile) then
                    write(11,*) 'The surface seems to be a trapped surface.'
                 end if
               end if
            else if (mtype.eq.4)then
               if (horizon) then
                 write(*,*) 'The surface seems to be a marginal horizon'
                 write(*,*) '(the integral of the expansion is positive'
                 write(*,*) 'on both sides.)'
                 if (logfile) then
                    write(11,*) 'The surface seems to be a marginal horizon'
                    write(11,*) '(the integral of the expansion is positive'
                    write(11,*) 'on both sides.)'
                 end if
               else
                 write(*,*) 'The surface does not seem to be a horizon.'
                 if (logfile) then
                    write(11,*) 'The surface does not seem to be a horizon.'
                 end if
               end if
            end if

!           Shape.

            if (verbose) then

               write(*,*)
               write(*,*) 'Shape coefficients:'

               if (offset) then
                  write(*,*)
                  write(*,"(A6,ES14.6)") ' xc  =',xc
                  write(*,"(A6,ES14.6)") ' yc  =',yc
                  write(*,"(A6,ES14.6)") ' zc  =',zc
               end if

               write(*,*)

               write(*,"(A4,I2,A3,ES14.6)") ' c0(',0,') =',c0(0)

               do l=1+stepz,lmax,1+stepz
                  write(*,"(A4,I2,A3,ES14.6)") ' c0(',l,') =',c0(l)
               end do

            end if

            if (logfile) then

               write(11,*)
               write(11,*) 'Shape coefficients:'

               if (offset) then
                  write(11,*)
                  write(11,"(A6,ES14.6)") ' xc  =',xc
                  write(11,"(A6,ES14.6)") ' yc  =',yc
                  write(11,"(A6,ES14.6)") ' zc  =',zc
               end if

               write(11,*)

               write(11,"(A4,I2,A3,ES14.6)") ' c0(',0,') =',c0(0)

               do l=1+stepz,lmax,1+stepz
                  write(11,"(A4,I2,A3,ES14.6)") ' c0(',l,') =',c0(l)
               end do

            end if

            if (nonaxi) then

               if (.not.refy) then

                  if (verbose) then

                     write(*,*)
                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(*,"(A4,I2,A1,I2,A4,ES14.6)") ' cc(',
     .                        l,',',m,')  =',cc(l,m)
                           end if
                        end do
                     end do
                     write(*,*)
                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(*,"(A4,I2,A1,I2,A4,ES14.6)") ' cs(',
     .                        l,',',m,')  =',cs(l,m)
                           end if
                        end do
                     end do

                  end if

                  if (logfile) then
                     write(11,*)

                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(11,"(A4,I2,A1,I2,A4,ES14.6)") ' cc(',
     .                        l,',',m,')  =',cc(l,m)
                           end if
                        end do
                     end do
                     write(11,*)
                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(11,"(A4,I2,A1,I2,A4,ES14.6)") ' cs(',
     .                        l,',',m,')  =',cs(l,m)
                           end if
                        end do
                     end do

                  end if

               else

                  if (verbose) then

                     write(*,*)
                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(*,"(A4,I2,A1,I2,A4,ES14.6)") ' cc(',
     .                        l,',',m,')  =',cc(l,m)
                           end if
                        end do
                     end do

                  end if

                  if (logfile) then

                     write(11,*)
                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(11,"(A4,I2,A1,I2,A4,ES14.6)") ' cc(',
     .                        l,',',m,')  =',cc(l,m)
                           end if
                        end do
                     end do

                  end if

               end if
            end if

!           Close logfile

            write(*,*)

            if (logfile) then
               write(11,*)
               write(11,*) 'END OF LOG FILE'
               write(11,*)
               close(11)
            end if

!        If we found a surface that is not a horizon and we
!        do not want to report all its details, just say that
!        we did not find a horizon.

         else if (myproc.eq.0) then

!           Open logfile.

            if (logfile) then
               open(11,file=logf,form='formatted',
     .         status='old',position='append')
            end if

!           Write messages.

            write(*,*)
            write(*,*) 'No horizon found.'

            if (logfile) then
               write(11,*)
               write(11,*) 'No horizon found.'
               write(11,*)
            end if

!           Close logfile

            write(*,*)

            if (logfile) then
               write(11,*)
               write(11,*) 'END OF LOG FILE'
               write(11,*)
               close(11)
            end if

         end if

!     No surface found.

      else

         mtype = 0
         report = .false.

         if (myproc.eq.0) then

!           Open logfile.

            if (logfile) then
               open(11,file=logf,form='formatted',
     .         status='old',position='append')
            end if

!           Write messages.

            write(*,*)
            write(*,*) 'No horizon found.'

            if (logfile) then
               write(11,*)
               write(11,*) 'No horizon found.'
               write(11,*)
            end if

!           Close logfile

            write(*,*)

            if (logfile) then
               write(11,*)
               write(11,*) 'END OF LOG FILE'
               write(11,*)
               close(11)
            end if

         end if
      end if


!     ******************************************************
!     ***   PREPARING  {ahfgrid3,ahf_exp3}  FOR OUTPUT   ***
!     ******************************************************

      if (find3) then
         call AHFinder_find3(CCTK_ARGUMENTS,mtype)
      end if


!     ****************************
!     ***   WRITE DATA FILES   ***
!     ****************************

      call AHFinder_Output(CCTK_ARGUMENTS,report,status,horizon,mtype,intarea_h)


!     ****************
!     ***   MASK   ***
!     ****************

!     Initialize the sides of the excised region to the center
!     of the expansion.

      if (ahf_ncall.eq.1) then

         if (find3) then

            if (mfind.eq.1) then

               dhole1_xmin = xc
               dhole1_ymin = yc
               dhole1_zmin = zc

               dhole1_xmax = xc
               dhole1_ymax = yc
               dhole1_zmax = zc

            else if (mfind.eq.2) then

               dhole2_xmin = xc
               dhole2_ymin = yc
               dhole2_zmin = zc

               dhole2_xmax = xc
               dhole2_ymax = yc
               dhole2_zmax = zc

            else

               dhole3_xmin = xc
               dhole3_ymin = yc
               dhole3_zmin = zc

               dhole3_xmax = xc
               dhole3_ymax = yc
               dhole3_zmax = zc

            end if

         else

            dhole1_xmin = xc
            dhole1_ymin = yc
            dhole1_zmin = zc

            dhole1_xmax = xc
            dhole1_ymax = yc
            dhole1_zmax = zc

         end if

      end if

!     The mask should only be different from 1 inside a horizon.
!     I therefore need to check first if I do have a horizon, and
!     also if the mask is desired.

      if ((horizon.and.(CCTK_EQUALS(ahf_mask,'strong'))).or.
     .   (status.and.(mtype.eq.1).and.(CCTK_EQUALS(ahf_mask,'weak')))) then

         rhor = 0.0D0

         if (find3) then
            if ((mfind.eq.1).and.(ahf_mask_0.eq.1)) then
               call AHFinder_mask(CCTK_ARGUMENTS,rhor)
            else if ((mfind.eq.2).and.(ahf_mask_1.eq.1)) then
               call AHFinder_mask(CCTK_ARGUMENTS,rhor)
            else if ((mfind.eq.3).and.(ahf_mask_2.eq.1)) then
               call AHFinder_mask(CCTK_ARGUMENTS,rhor)
            end if
         else
            call AHFinder_mask(CCTK_ARGUMENTS,rhor)
         end if

!        Here I alter the parameters for SimpleExcision.  Notice that at
!        the moment, I only allow the excised cube to grow, and never
!        to shrink.  Also, notice that the sides of the cube have been
!        set to 0.57*rhor.  This is because if we want the corners of
!        the cube to touch a sphere of radius rhor, we need to make the
!        sides equal to 1/sqrt(3), which is roughly 0.57.  If you worry
!        that this is too close to the horizon, remember that rhor in fact
!        has already been shrunk by a safety margin.

         aux = 0.57D0*rhor

         if (find3) then

            if (mfind.eq.1) then

!              First hole.

               if (dhole1_xmin.gt.(xc-aux)) dhole1_xmin = xc-aux
               if (dhole1_ymin.gt.(yc-aux)) dhole1_ymin = yc-aux
               if (dhole1_zmin.gt.(zc-aux)) dhole1_zmin = zc-aux

               if (dhole1_xmax.lt.(xc+aux)) dhole1_xmax = xc+aux
               if (dhole1_ymax.lt.(yc+aux)) dhole1_ymax = yc+aux
               if (dhole1_zmax.lt.(zc+aux)) dhole1_zmax = zc+aux

            else if (mfind.eq.2) then

!              Second hole.

               if (dhole2_xmin.gt.(xc-aux)) dhole2_xmin = xc-aux
               if (dhole2_ymin.gt.(yc-aux)) dhole2_ymin = yc-aux
               if (dhole2_zmin.gt.(zc-aux)) dhole2_zmin = zc-aux

               if (dhole2_xmax.lt.(xc+aux)) dhole2_xmax = xc+aux
               if (dhole2_ymax.lt.(yc+aux)) dhole2_ymax = yc+aux
               if (dhole2_zmax.lt.(zc+aux)) dhole2_zmax = zc+aux

            else

!              Third hole.

               if (dhole3_xmin.gt.(xc-aux)) dhole3_xmin = xc-aux
               if (dhole3_ymin.gt.(yc-aux)) dhole3_ymin = yc-aux
               if (dhole3_zmin.gt.(zc-aux)) dhole3_zmin = zc-aux

               if (dhole3_xmax.lt.(xc+aux)) dhole3_xmax = xc+aux
               if (dhole3_ymax.lt.(yc+aux)) dhole3_ymax = yc+aux
               if (dhole3_zmax.lt.(zc+aux)) dhole3_zmax = zc+aux

            end if

         else

            if (dhole1_xmin.gt.(xc-aux)) dhole1_xmin = xc-aux
            if (dhole1_ymin.gt.(yc-aux)) dhole1_ymin = yc-aux
            if (dhole1_zmin.gt.(zc-aux)) dhole1_zmin = zc-aux

            if (dhole1_xmax.lt.(xc+aux)) dhole1_xmax = xc+aux
            if (dhole1_ymax.lt.(yc+aux)) dhole1_ymax = yc+aux
            if (dhole1_zmax.lt.(zc+aux)) dhole1_zmax = zc+aux

         end if

      end if


!     ********************************************************
!     ***   END OF LOOP FOR LOOKING FOR SEVERAL HORIZONS   ***
!     ********************************************************

!     End of "giveup" if statement.

      end if

!     If we are looking for 3 horizons, save values of coefficients.

      if (find3) then
         if (mfind.eq.1) then
            c0_0 = c0
            cc_0 = cc
            cs_0 = cs
         else if (mfind.eq.2) then
            c0_1 = c0
            cc_1 = cc
            cs_1 = cs
         else
            c0_2 = c0
            cc_2 = cc
            cs_2 = cs
         end if
      end if

      write (*,*)

      end do


!     *******************************************************
!     ***   CALCULATE PROPER DISTANCES BETWEEN HORIZONS   ***
!     *******************************************************

      if (find3) then
         call AHFinder_dis(CCTK_ARGUMENTS)
      end if


!     **************************************************
!     ***   TRANSFORM PHYSICAL TO CONFORMAL METRIC   ***
!     **************************************************

!     If necesary, change back the metric to conformal
!     and change back the "conformal_state" flag.

      if (ahfconformal) then

         conformal_state = save_conformal_state

         call PhysToConfInPlace (int(nx,ik),int(ny,ik),int(nz,ik),psi,
     &        gxx,gxy,gxz,gyy,gyz,gzz)

      end if


!     ***************
!     ***   END   ***
!     ***************

      end subroutine AHFinder

```

AHFinder_leg.F:
```
/*@@
  @file      AHFinder_leg.F
  @date      April 1998
  @author    Miguel Alcubierre
  @desc 
             Associated Legendre functions.
  @enddesc 
@@*/

#include "cctk.h"

      CCTK_REAL function LEGEN(L,M,X)

!     This function computes the associated Legendre polynomial
!     P^M_L(X).  Here M and L are integers satisfying 0 <= M <= L,
!     and X lies in the range -1 <= X <= 1.
!
!     The general function is taken from Numerical Recipes.
!     However, I hardwired the first few polynomials for M=0,
!     and I added a section that tries to use as much information
!     as possible from previous calls to the routine to avoid
!     having to start from scratch every time.

      use AHFinder_dat

      implicit none

      integer L,M
      integer LOLD1,LOLD2,MOLD1,MOLD2
      integer I,LL

      CCTK_REAL X,Y
      CCTK_REAL PMM,PLL,PMMP1,SOMX2,FACT
      CCTK_REAL factor,aux
      CCTK_REAL zero,one,two
      CCTK_REAL XOLD1,XOLD2
      CCTK_REAL LEGOLD1,LEGOLD2

      save LOLD1,LOLD2,MOLD1,MOLD2,XOLD1,XOLD2
      save LEGOLD1,LEGOLD2


!     **************************
!     ***   DEFINE NUMBERS   ***
!     **************************

      zero = 0.0D0
      one  = 1.0D0
      two  = 2.0D0


!     *************************************************
!     ***   HARDWIRE FIRST FEW POLYNOMIALS FOR M=0  ***
!     *************************************************

!     Notice that it does not make sense to go much higher
!     than L=12 since the explicit expressions for the
!     polynomials have large terms with alternating signs,
!     so for high L we rapidly loose accuracy in the sum.
!     The method from Numerical Recipes that comes below
!     is slow, but does not have this problem.

      Y = X**2

!     Find polynomials for M=0.

      if ((M.eq.0).and.(L.le.12)) then

         if (L.eq.0) then
            LEGEN = one
            goto 10
         else if (L.eq.1) then
            LEGEN = X
            goto 10
         else if (L.eq.2) then
            LEGEN = 5.0D-1*(3.0D0*Y - one)
            goto 10
         else if (L.eq.3) then
            LEGEN = 5.0D-1*(5.0D0*Y - 3.0D0)*X
            goto 10
         else if (L.eq.4) then
            LEGEN = 1.25D-1*(35.0D0*Y**2 - 30.0D0*Y + 3.0D0)
            goto 10
         else if (L.eq.5) then
            LEGEN = 1.25D-1*(63.0D0*Y**2 - 70.0D0*Y + 15.0D0)*X
            goto 10
         else if (L.eq.6) then
            LEGEN = 6.25D-2*(231.0D0*Y**3 - 315.0D0*Y**2 + 105.0D0*Y
     .            - 5.0D0)
            goto 10
         else if (L.eq.7) then
            LEGEN = 6.25D-2*(429.0D0*Y**3 - 693.0D0*Y**2 + 315.0D0*Y
     .            - 35.0D0)*X
            goto 10
         else if (L.eq.8) then
            LEGEN = 7.8125D-3*(6435.0D0*Y**4 - 12012.0D0*Y**3
     .            + 6930.0D0*Y**2 - 1260.0D0*Y + 35.0D0)
            goto 10
         else if (L.eq.9) then
            LEGEN = 7.8125D-3*(12155.0D0*Y**4 - 25740.0D0*Y**3
     .            + 18018.0D0*Y**2 - 4620.0D0*Y + 315.0D0)*X
            goto 10
         else if (L.eq.10) then
            LEGEN = 3.90625D-3*(46189.0D0*Y**5 - 109395.0D0*Y**4
     .            + 90090.0D0*Y**3 - 30030.0D0*Y**2 + 3465.0D0*Y
     .            - 63.0D0)
            goto 10
         else if (L.eq.11) then
            LEGEN = 3.90625D-3*(88179.0D0*Y**5 - 230945.0D0*Y**4
     .            + 218790.0D0*Y**3  - 90090.0D0*Y**2 + 15015.0D0*Y
     .            - 693.0D0)*X
            goto 10
         else if (L.eq.12) then
            LEGEN = 9.76563D-4*(676039.0D0*Y**6 - 1939938.0D0*Y**5
     .            + 2078505.0D0*Y**4 - 1021020.0D0*Y**3
     .            + 225225.0D0*Y**2 - 18018.0D0*Y + 231.0D0)
            goto 10
         end if

      end if


!     ***********************************************
!     ***   USE RECURSIVE RELATIONS IF POSSIBLE   ***
!     ***********************************************

!     Here I try to optimize the calculation of the Legendre
!     polynomials (which is ordinarily very expensive) by using
!     the recurrence relations and information from the last
!     calls to the routine.

      if (firstleg) then

         LOLD1   = -2
         MOLD1   = -2
         XOLD1   = zero
         LEGOLD1 = zero

         firstleg = .false.

      else

!        See if we have the same values of M and X as the last call.

         if ((M.eq.MOLD1).and.(X.eq.XOLD1).and.(L.ne.M)) then

!           If L is the same as in the last call, then
!           LEGEN should also be the same. This will
!           almost certainly never happen.

            if (L.eq.LOLD1) then

               LEGEN = LEGOLD1
               goto 10

!           This is the most interesting case L = LOLD1+1.

            else if (L.eq.LOLD1+1) then

!              LOLD1 = MOLD1.

               if (LOLD1.eq.MOLD1) then

                  LEGEN = X*dble(2*M+1)*LEGOLD1
                  goto 10

!              LOLD1 = LOLD2 + 1.

               else if ((L.eq.LOLD2+2).and.(X.eq.XOLD2)) then

                  LEGEN = (X*dble(2*L-1)*LEGOLD1 - dble(L+M-1)*LEGOLD2)
     .                  / dble(L-M)
                  goto 10

               end if

            end if

         end if

      end if


!     *************************************
!     ***   NUMERICAL RECIPES ROUTINE   ***
!     *************************************

!     Compute P^M_M.

      PMM = one

      if (M.gt.0) then

         SOMX2 = sqrt((one-X)*(one+X))
         FACT = one

         do I=1,M
            PMM = - PMM*FACT*SOMX2
            FACT = FACT + two
         end do

      end if

      if (L.eq.M) then

         LEGEN = PMM

!     Compute P^M_M+1.

      else

         PMMP1 = X*dble(2*M+1)*PMM

         if (L.eq.M+1) then

            LEGEN = PMMP1

!        Compute P^M_L, L > M+1.

         else

            do LL=M+2,L
               PLL = (X*dble(2*LL-1)*PMMP1 - dble(LL+M-1)*PMM)
     .             / dble(LL-M)
               PMM = PMMP1
               PMMP1 = PLL
            end do

            LEGEN = PLL

          end if

      end if


!     ***************************
!     ***   SAVE OLD VALUES   ***
!     ***************************

   10 continue

      LOLD2   = LOLD1
      MOLD2   = MOLD1
      XOLD2   = XOLD1
      LEGOLD2 = LEGOLD1

      LOLD1   = L
      MOLD1   = M
      XOLD1   = X
      LEGOLD1 = LEGEN


!     **********************************************
!     ***   MULTIPLY WITH NORMALIZATION FACTOR   ***
!     **********************************************

!     For M=0 I use the normalization factor:
!
!     sqrt(2*L + 1)
!
!     For M non-zero I use the normalization factor:
!
!     sqrt( 2 (2*L + 1) (L-M)! / (L+M)! )
!
!     The extra factor of sqrt(2) is there because I
!     use a basis of sines and cosines and not the
!     standard complex exponential.
!
!     With this normalization, I ensure that my basis
!     functions f _lm are such that:
!
!     /
!     | f_lm f_l;mp sin(theta) dtheta dphi  =  4 pi delta_mm' delta_ll'
!     /
!
!     Notice the extra factor of 4 pi.  This is there because
!     for a sphere, I want the (0,0) coefficient to correspond
!     to the radius.

      factor = dble(2*L+1)

      if (M.ne.0) then
 
         aux = one
 
         do i=L-M+1,L+M
            aux = aux*dble(i)
         end do
 
         factor = two*factor/aux
 
      end if

      LEGEN = sqrt(factor)*LEGEN


!     ***************
!     ***   END   ***
!     ***************

      end function LEGEN




```

AHFinder_fun.F:
```
/*@@
  @file      AHFinder_fun.F
  @date      April 1998
  @author    Miguel Alcubierre
  @desc 
             Find horizon function.
  @enddesc 
@@*/

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

      subroutine AHFinder_fun(CCTK_ARGUMENTS)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS
      DECLARE_CCTK_FUNCTIONS

      integer i,j,k
      integer l,m

      CCTK_REAL xp,yp,zp,rp
      CCTK_REAL phi,cost,cosa,sina
      CCTK_REAL zero,half,one,two
      CCTK_REAL pi,halfpi,twopi
      CCTK_REAL aux1,aux2
      CCTK_REAL local_legen,local_legen_old,local_legen_old_old 
      CCTK_REAL cc_cosa(lmax,lmax),cs_sina(lmax,lmax)
      CCTK_REAL dsqrt_factor(lmax,lmax),dsqrt_factor2(lmax)
      CCTK_REAL lm_factor1(0:lmax,0:lmax),lm_factor2(0:lmax,0:lmax)
      CCTK_REAL lm_factor3(lmax)
      CCTK_REAL sinphi,cosphi,sinphi1,cosphi1,sinphi2,cosphi2
      CCTK_REAL legen_base


!     **************************
!     ***   DEFINE NUMBERS   ***
!     **************************

      zero = 0.0D0
      half = 0.5D0
      one  = 1.0D0
      two  = 2.0D0

      pi     = acos(-one)
      halfpi = half*pi
      twopi  = two*pi


!     *******************************************
!     ***   FACTORS FOR SPHERICAL HARMONICS   ***
!     *******************************************

!     Compute the normalization factors only once for all (l,m)
!
!     For M=0 I use the normalization factor:
!
!     sqrt(2*L + 1)
!
!     For M non-zero I use the normalization factor:
!
!     sqrt( 2 (2*L + 1) (L-M)! / (L+M)! )
!
!     The extra factor of sqrt(2) is there because I
!     use a basis of sines and cosines and not the
!     standard complex exponential.
!
!     With this normalization, I ensure that my basis
!     functions f _lm are such that:
!
!     /
!     | f_lm f_l;mp sin(theta) dtheta dphi  =  4 pi delta_mm' delta_ll'
!     /
!
!     Notice the extra factor of 4 pi.  This is there because
!     for a sphere, I want the (0,0) coefficient to correspond
!     to the radius.
!
!     Also compute the multiplying factors in the recursion relations

!     Initialize.

      lm_factor1 = zero
      lm_factor2 = zero
      lm_factor3 = zero

      dsqrt_factor  = zero
      dsqrt_factor2 = zero

!     M=0.

      do l=1,lmax

         dsqrt_factor2(l) = c0(l)*sqrt(dble(2*l+1))

         lm_factor1(l,0) = dble(2*l-1)/dble(l)
         lm_factor2(l,0) = dble(l-1)/dble(l)
         lm_factor3(l)   = dble(2*l-1)

      end do

!     M > 0.

      if (nonaxi) then

         do l=1,lmax

            dsqrt_factor(l,1) = sqrt(2.0D0*dble(2*l+1)/dble(l*(l+1)))

            do m=2,l
               dsqrt_factor(l,m) = dsqrt_factor(l,m-1)
     .                           / sqrt(dble((l-m+1)*(l+m)))
            end do

         end do

         do l=2,lmax

            lm_factor1(l,1) = dble(2*l-1)/dble(l-1)
            lm_factor2(l,1) = dble(l)/dble(l-1)

            do m=2,l-1
               lm_factor1(l,m) = dble(2*l-1)/dble(l-m)
               lm_factor2(l,m) = dble(l+m-1)/dble(l-m)
            end do

         end do

      end if


!     *********************************
!     ***   FIND HORIZON FUNCTION   ***
!     *********************************

!     Loop over j.

      do j=1,ny

!        Find yp.

         yp = y(1,j,1) - yc

!        Loop over i.

         do i=1,nx

!           Find xp.

            xp = x(i,1,1) - xc

!           Find sines and cosines of phi.

            if (nonaxi) then

!              Find phi.

               if (yp.ne.zero) then
                  phi = atan2(yp,xp)
               else
                  phi = zero
               end if

!              Compute the expensive sines and cosines only once
!              for all (l,m) using the recursion relations:
!
!              cos(m*phi) = 2*cos((m-1)*phi)*cos(phi)-cos((m-2)*phi)
!              sin(m*phi) = 2*sin((m-1)*phi)*cos(phi)-sin((m-2)*phi)

               cosphi  = cos(phi)
               cosphi1 = one
               cosphi2 = cosphi

               if (.not.refy) then
                  sinphi  = sin(phi)
                  sinphi1 = zero
                  sinphi2 = sinphi
               end if

!              M=1.

               do l=1,lmax

                  cc_cosa(l,1) = cc(l,1)*cosphi*dsqrt_factor(l,1)

                  if (.not.refy) then
                     cs_sina(l,1) = cs(l,1)*sinphi*dsqrt_factor(l,1)
                  end if

               end do

!              M>1.

               do m=2,lmax

                  cosa = 2.0D0*cosphi2*cosphi - cosphi1

                  cosphi1 = cosphi2
                  cosphi2 = cosa

                  do l=m,lmax
                     cc_cosa(l,m) = cc(l,m)*cosa*dsqrt_factor(l,m)
                  end do 

                  if (.not.refy) then

                     sina = 2.0D0*sinphi2*cosphi - sinphi1

                     sinphi1 = sinphi2
                     sinphi2 = sina

                     do l=m,lmax
                        cs_sina(l,m) = cs(l,m)*sina*dsqrt_factor(l,m)
                     end do

                  end if

              end do

            end if

!           Loop over k.

            do k=1,nz

!              Find zp.

               zp = z(i,j,k) - zc

!              Find rp.

               rp = sqrt(xp**2 + yp**2 + zp**2)

!              Monopole term.

               aux1 = c0(0)

!              Axisymmetric terms.

               if (rp.ne.zero) then
                  cost = zp/rp
               else
                  cost = one
               end if

!              Compute the contribution from M=0, L=1,Lmax using
!              the recursion relations from Numerical Recipes.

               if (lmax.gt.0) then

!                 L=1

                  legen_base = one
                  local_legen_old_old = one
                  local_legen_old = cost

                  aux1 = aux1 + dsqrt_factor2(1)*local_legen_old

!                 L=2,lmax

                  do l=2,lmax

                     local_legen = cost*lm_factor1(l,0)*local_legen_old
     .                                - lm_factor2(l,0)*local_legen_old_old
                     local_legen_old_old = local_legen_old
                     local_legen_old = local_legen

                     aux1 = aux1 + dsqrt_factor2(l)*local_legen

                  end do
!                  
!                 Non-axisymmetric terms.
!
                  if (nonaxi) then

                     aux2 = sqrt((one-cost)*(one+cost))

!                    This general loop can only be used until l=lmax-2 since
!                    the recursion relations requires 2 starting values.

                     do m=1,lmax-2
! L=M
                        legen_base = -legen_base*aux2*lm_factor3(m)     

                        aux1 = aux1 + legen_base*cc_cosa(m,m)

                        if (.not.refy) then
                           aux1 = aux1 + legen_base*cs_sina(m,m)
                        end if

                        local_legen_old_old = legen_base
! L=M+1
                        local_legen_old = cost*lm_factor3(m+1)         
     .                                  *legen_base

                        aux1 = aux1 + local_legen_old*cc_cosa(m+1,m)

                        if (.not.refy) then
                           aux1 = aux1 + local_legen_old*cs_sina(m+1,m)
                        end if

! L=M+2,lmax
                        do l=m+2,lmax                             

                           local_legen = cost*lm_factor1(l,m)*local_legen_old
     .                                      - lm_factor2(l,m)*local_legen_old_old
                           local_legen_old_old = local_legen_old
                           local_legen_old = local_legen

                           aux1 = aux1 + local_legen*cc_cosa(l,m)

                           if (.not.refy) then
                              aux1 = aux1 + local_legen*cs_sina(l,m)
                           end if

                        end do
                     end do

!                    Then do M=lmax-1

                     if (lmax.gt.1) then

! L=lmax-1
                        m=lmax-1                                   
                        legen_base = -legen_base*aux2*lm_factor3(m)   
                        aux1 = aux1 + legen_base*cc_cosa(m,m)

                        if (.not.refy) then
                           aux1 = aux1 + legen_base*cs_sina(m,m)
                        end if

! L=lmax
                        local_legen = cost*lm_factor3(lmax)*   
     .                                            legen_base
                        aux1 = aux1 + local_legen*cc_cosa(lmax,m)

                        if (.not.refy) then
                           aux1 = aux1 + local_legen*cs_sina(lmax,m)
                        end if

                     end if

!                    And finally do M=lmax.

! L=lmax
                     m=lmax                                         

                     legen_base = -legen_base*aux2*lm_factor3(m)
                     aux1 = aux1 + legen_base*cc_cosa(m,m)

                     if (.not.refy) then
                        aux1 = aux1 + legen_base*cs_sina(m,m)
                     end if

                  end if

               end if

!              Find horizon function.

               ahfgrid(i,j,k) = rp - aux1

            end do
         end do
      end do


!     ***************
!     ***   END   ***
!     ***************

      end subroutine AHFinder_fun


```

make.code.defn:
```
# Main make.code.defn file for thorn AHFinder
# Source files in this directory

SRCS += AHFinder_dat.F AHFinder.F \
        AHFinder_fun.F AHFinder_exp.F AHFinder_dis.F AHFinder_int.F \
        AHFinder_min.F AHFinder_pow.F AHFinder_leg.F \
        AHFinder_flow.F AHFinder_mask.F AHFinder_output.F \
        AHFinder_find3.F AHFinder_calcsigma.F \
        AHFinder_initguess.F AHFinder_gau.F SetSym.F \
        AHFinder_ParamCheck.F90 \
        Startup.c Output.c

#ifeq ($(shell uname), Darwin)
#  F90FLAGS += -N11
#endif

```

AHFinder_exp.F:
```
/*@@
  @file      AHFinder_exp.F
  @date      April 1998
  @author    Miguel Alcubierre
  @desc 
            Here I calculate the (normalized) expansion of the
            horizon function. The expansion is defined by the
            following expression:

                    __2                     2 /  ab  __a__b      \
            exp  =  \/ f / u  +  d f d f / u  | K  - \/ \/ f / u |  -  trK
                                  a   b       \                  /

            where:

                  /  mn         \ 1/2
            u  =  | g   d f d f |
                  \      m   n  /

  @enddesc
  @version   $Header$
@@*/

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

      subroutine AHFinder_exp(CCTK_ARGUMENTS)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS

      integer i,j,k

      CCTK_REAL det,idet
      CCTK_REAL gdxx,gdyy,gdzz,gdxy,gdxz,gdyz
      CCTK_REAL guxx,guyy,guzz,guxy,guxz,guyz
      CCTK_REAL kdxx,kdyy,kdzz,kdxy,kdxz,kdyz
      CCTK_REAL ddxxx,ddxyy,ddxzz,ddxxy,ddxxz,ddxyz
      CCTK_REAL ddyxx,ddyyy,ddyzz,ddyxy,ddyxz,ddyyz
      CCTK_REAL ddzxx,ddzyy,ddzzz,ddzxy,ddzxz,ddzyz
      CCTK_REAL d2fxx,d2fyy,d2fzz,d2fxy,d2fxz,d2fyz
      CCTK_REAL c2fxx,c2fyy,c2fzz,c2fxy,c2fxz,c2fyz
      CCTK_REAL dfx,dfy,dfz,dfux,dfuy,dfuz
      CCTK_REAL aux,T0,T1,T2,T3,T4
      CCTK_REAL idx,idy,idz
      CCTK_REAL idx2,idy2,idz2,idxy,idxz,idyz
      CCTK_REAL zero,half,one,two

!     Description of variables:
!
!     i,j,k,          counters
!
!     gdij            g
!                      ij
!                      ij
!     guij            g
!
!
!     det             det(g)
!
!     idet            1/det
!
!
!     kdij            K
!                      ij
!
!     ddijk           d g
!                      i jk
!
!     dfi             d f
!                      i
!                      ij
!     dfui            g  d f
!                         j
!
!     d2fij           d d f
!                      i j
!
!     c2fij           f
!                      ;ij
!
!     aux,T*          auxilliary variables


!     *******************
!     ***   NUMBERS   ***
!     *******************

      zero = 0.0d0
      half = 0.5d0
      one  = 1.0d0
      two  = 2.0d0


!     **************************
!     ***   FIND EXPANSION   ***
!     **************************

      idx = half/dx
      idy = half/dy
      idz = half/dz

      idx2 = one/dx**2
      idy2 = one/dy**2
      idz2 = one/dz**2

      idxy = idx*idy
      idxz = idx*idz
      idyz = idy*idz

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

!              Find spatial metric.

               gdxx = gxx(i,j,k)
               gdyy = gyy(i,j,k)
               gdzz = gzz(i,j,k)
               gdxy = gxy(i,j,k)
               gdxz = gxz(i,j,k)
               gdyz = gyz(i,j,k)

!              Find extrinsic curvature.

               kdxx = kxx(i,j,k)
               kdyy = kyy(i,j,k)
               kdzz = kzz(i,j,k)
               kdxy = kxy(i,j,k)
               kdxz = kxz(i,j,k)
               kdyz = kyz(i,j,k)

!              Find derivatives of metric using finite differences.

               ddxxx = idx*(gxx(i+1,j,k) - gxx(i-1,j,k))
               ddxyy = idx*(gyy(i+1,j,k) - gyy(i-1,j,k))
               ddxzz = idx*(gzz(i+1,j,k) - gzz(i-1,j,k))
               ddxxy = idx*(gxy(i+1,j,k) - gxy(i-1,j,k))
               ddxxz = idx*(gxz(i+1,j,k) - gxz(i-1,j,k))
               ddxyz = idx*(gyz(i+1,j,k) - gyz(i-1,j,k))

               ddyxx = idy*(gxx(i,j+1,k) - gxx(i,j-1,k))
               ddyyy = idy*(gyy(i,j+1,k) - gyy(i,j-1,k))
               ddyzz = idy*(gzz(i,j+1,k) - gzz(i,j-1,k))
               ddyxy = idy*(gxy(i,j+1,k) - gxy(i,j-1,k))
               ddyxz = idy*(gxz(i,j+1,k) - gxz(i,j-1,k))
               ddyyz = idy*(gyz(i,j+1,k) - gyz(i,j-1,k))

               ddzxx = idz*(gxx(i,j,k+1) - gxx(i,j,k-1))
               ddzyy = idz*(gyy(i,j,k+1) - gyy(i,j,k-1))
               ddzzz = idz*(gzz(i,j,k+1) - gzz(i,j,k-1))
               ddzxy = idz*(gxy(i,j,k+1) - gxy(i,j,k-1))
               ddzxz = idz*(gxz(i,j,k+1) - gxz(i,j,k-1))
               ddzyz = idz*(gyz(i,j,k+1) - gyz(i,j,k-1))

!              Find determinant of spatial metric.

               det = gdxx*gdyy*gdzz + two*gdxy*gdxz*gdyz
     .             - gdxx*gdyz**2 - gdyy*gdxz**2 - gdzz*gdxy**2

!              If determinant is not zero proceed.

               if (det.gt.zero) then

                  idet = one/det

!                 Find inverse spatial metric.

                  guxx = idet*(gdyy*gdzz - gdyz**2)
                  guyy = idet*(gdxx*gdzz - gdxz**2)
                  guzz = idet*(gdxx*gdyy - gdxy**2)

                  guxy = idet*(gdxz*gdyz - gdzz*gdxy)
                  guxz = idet*(gdxy*gdyz - gdyy*gdxz)
                  guyz = idet*(gdxy*gdxz - gdxx*gdyz)

!                 Find spatial derivatives of f.
                  
                  T0 = two*ahfgrid(i,j,k)
              
                  T1 = ahfgrid(i+1,j,k)
                  T2 = ahfgrid(i-1,j,k)
           
                  dfx   = (T1 - T2)*idx
                  d2fxx = (T1 - T0 + T2)*idx2

                  T1 = ahfgrid(i,j+1,k)
                  T2 = ahfgrid(i,j-1,k)

                  dfy   = (T1 - T2)*idy
                  d2fyy = (T1 - T0 + T2)*idy2

                  T1 = ahfgrid(i,j,k+1)
                  T2 = ahfgrid(i,j,k-1)

                  dfz   = (T1 - T2)*idz
                  d2fzz = (T1 - T0 + T2)*idz2

!                 Save gradient of horizon function and its norm
!                 (they will be needed later in the flow algorithm
!                 and in the gaussian curvature).  Here I also try
!                 to avoid possible division by zero later by not
!                 allowing   ahfgradn(i,j,k) = 0.  This should only
!                 ever happen far from the horizon, so resetting this
!                 to 1 should have no important effects.

                  ahfgradx(i,j,k) = dfx
                  ahfgrady(i,j,k) = dfy
                  ahfgradz(i,j,k) = dfz

                  aux = guxx*dfx**2 + guyy*dfy**2 + guzz*dfz**2
     .                 + two*(guxy*dfx*dfy + guxz*dfx*dfz + guyz*dfy*dfz)

                  ahfgradn(i,j,k) = sqrt(aux)
                  if (ahfgradn(i,j,k).eq.zero) ahfgradn(i,j,k) = one

!                 Find crossed derivatives.

                  d2fxy = (ahfgrid(i+1,j+1,k) + ahfgrid(i-1,j-1,k)
     .                  -  ahfgrid(i+1,j-1,k) - ahfgrid(i-1,j+1,k))*idxy
                  d2fxz = (ahfgrid(i+1,j,k+1) + ahfgrid(i-1,j,k-1)
     .                  -  ahfgrid(i+1,j,k-1) - ahfgrid(i-1,j,k+1))*idxz
                  d2fyz = (ahfgrid(i,j+1,k+1) + ahfgrid(i,j-1,k-1)
     .                  -  ahfgrid(i,j+1,k-1) - ahfgrid(i,j-1,k+1))*idyz

!                 Raise indices in first derivatives.

                  dfux = guxx*dfx + guxy*dfy + guxz*dfz
                  dfuy = guxy*dfx + guyy*dfy + guyz*dfz
                  dfuz = guxz*dfx + guyz*dfy + guzz*dfz
                  
!                 Find second covariant derivatives of f.

                  c2fxx = d2fxx - half*(dfux*ddxxx
     .                 + dfuy*(two*ddxxy - ddyxx)
     .                 + dfuz*(two*ddxxz - ddzxx))
                  
                  c2fyy = d2fyy - half*(dfuy*ddyyy
     .                 + dfux*(two*ddyxy - ddxyy)
     .                 + dfuz*(two*ddyyz - ddzyy))

                  c2fzz = d2fzz - half*(dfuz*ddzzz
     .                 + dfux*(two*ddzxz - ddxzz)
     .                 + dfuy*(two*ddzyz - ddyzz))

                  c2fxy = d2fxy - half*(dfux*ddyxx + dfuy*ddxyy
     .                 + dfuz*(ddxyz + ddyxz - ddzxy))

                  c2fxz = d2fxz - half*(dfux*ddzxx + dfuz*ddxzz
     .                 + dfuy*(ddxyz + ddzxy - ddyxz))

                  c2fyz = d2fyz - half*(dfuy*ddzyy + dfuz*ddyzz
     .                 + dfux*(ddyxz + ddzxy - ddxyz))

!                              /  m      \ 1/2
!                 Find:  u  =  | d f d f |
!                              \      m  /

                  T0 = dfx*dfux + dfy*dfuy + dfz*dfuz

!                 if T0 is positive proceed.

                  if (T0.gt.zero) then

                     T0 = one/sqrt(T0)

!                           __2
!                    Find:  \/ f / u

                     T1 = guxx*c2fxx + guyy*c2fyy + guzz*c2fzz
     .                    + two*(guxy*c2fxy + guxz*c2fxz + guyz*c2fyz)

                     T1 = T1*T0

!                                a   b       2
!                    Find:  K   d f d f  /  u
!                            ab
                     
                     T2 = kdxx*dfux**2 + kdyy*dfuy**2 + kdzz*dfuz**2
     .                    + two*(dfux*(kdxy*dfuy + kdxz*dfuz) + kdyz*dfuy*dfuz)

                     T2 = T2*T0**2

!                            __a__b                3
!                    Find:   \/ \/ f  d f d f  /  u
!                                      a   b

                     T3 = c2fxx*dfux**2 + c2fyy*dfuy**2 + c2fzz*dfuz**2
     .                    + two*(dfux*(c2fxy*dfuy + c2fxz*dfuz)
     .                    + c2fyz*dfuy*dfuz)

                     T3 = T3*T0**3

!                    Find:  trK

                     T4 = guxx*kdxx + guyy*kdyy + guzz*kdzz
     .                    + two*(guxy*kdxy + guxz*kdxz + guyz*kdyz)

!                    Find the expansion.

                     ahf_exp(i,j,k) = T1 + T2 - T3 - T4

!                 T0 was not positive.

                  else
                     ahf_exp(i,j,k) = zero
                  end if

!              Determinant was zero.

               else
                  ahf_exp(i,j,k) = zero
               end if

            end do
         end do
      end do

!     Zero out the edges before doing the boundaries.

      ahf_exp( 1, 1, :) = 0.0d0
      ahf_exp( 1,ny, :) = 0.0d0
      ahf_exp( 1, :, 1) = 0.0d0
      ahf_exp( 1, :,nz) = 0.0d0
      ahf_exp(nx, 1, :) = 0.0d0
      ahf_exp(nx,ny, :) = 0.0d0
      ahf_exp(nx, :, 1) = 0.0d0
      ahf_exp(nx, :,nz) = 0.0d0
      ahf_exp( :, 1, 1) = 0.0d0
      ahf_exp( :,ny, 1) = 0.0d0
      ahf_exp( :, 1,nz) = 0.0d0
      ahf_exp( :,ny,nz) = 0.0d0

      ahfgradx( 1, 1, :) = 0.0d0
      ahfgradx( 1,ny, :) = 0.0d0
      ahfgradx( 1, :, 1) = 0.0d0
      ahfgradx( 1, :,nz) = 0.0d0
      ahfgradx(nx, 1, :) = 0.0d0
      ahfgradx(nx,ny, :) = 0.0d0
      ahfgradx(nx, :, 1) = 0.0d0
      ahfgradx(nx, :,nz) = 0.0d0
      ahfgradx( :, 1, 1) = 0.0d0
      ahfgradx( :,ny, 1) = 0.0d0
      ahfgradx( :, 1,nz) = 0.0d0
      ahfgradx( :,ny,nz) = 0.0d0

      ahfgrady( 1, 1, :) = 0.0d0
      ahfgrady( 1,ny, :) = 0.0d0
      ahfgrady( 1, :, 1) = 0.0d0
      ahfgrady( 1, :,nz) = 0.0d0
      ahfgrady(nx, 1, :) = 0.0d0
      ahfgrady(nx,ny, :) = 0.0d0
      ahfgrady(nx, :, 1) = 0.0d0
      ahfgrady(nx, :,nz) = 0.0d0
      ahfgrady( :, 1, 1) = 0.0d0
      ahfgrady( :,ny, 1) = 0.0d0
      ahfgrady( :, 1,nz) = 0.0d0
      ahfgrady( :,ny,nz) = 0.0d0

      ahfgradz( 1, 1, :) = 0.0d0
      ahfgradz( 1,ny, :) = 0.0d0
      ahfgradz( 1, :, 1) = 0.0d0
      ahfgradz( 1, :,nz) = 0.0d0
      ahfgradz(nx, 1, :) = 0.0d0
      ahfgradz(nx,ny, :) = 0.0d0
      ahfgradz(nx, :, 1) = 0.0d0
      ahfgradz(nx, :,nz) = 0.0d0
      ahfgradz( :, 1, 1) = 0.0d0
      ahfgradz( :,ny, 1) = 0.0d0
      ahfgradz( :, 1,nz) = 0.0d0
      ahfgradz( :,ny,nz) = 0.0d0

      ahfgradn( 1, 1, :) = 0.0d0
      ahfgradn( 1,ny, :) = 0.0d0
      ahfgradn( 1, :, 1) = 0.0d0
      ahfgradn( 1, :,nz) = 0.0d0
      ahfgradn(nx, 1, :) = 0.0d0
      ahfgradn(nx,ny, :) = 0.0d0
      ahfgradn(nx, :, 1) = 0.0d0
      ahfgradn(nx, :,nz) = 0.0d0
      ahfgradn( :, 1, 1) = 0.0d0
      ahfgradn( :,ny, 1) = 0.0d0
      ahfgradn( :, 1,nz) = 0.0d0
      ahfgradn( :,ny,nz) = 0.0d0

!     Boundaries on x direction.

      ahf_exp(1,2:ny-1,2:nz-1)  = 2.0D0*ahf_exp(2,2:ny-1,2:nz-1)
     .   - ahf_exp(3,2:ny-1,2:nz-1)
      ahfgradx(1,2:ny-1,2:nz-1) = 2.0D0*ahfgradx(2,2:ny-1,2:nz-1)
     .   - ahfgradx(3,2:ny-1,2:nz-1)
      ahfgrady(1,2:ny-1,2:nz-1) = 2.0D0*ahfgrady(2,2:ny-1,2:nz-1)
     .   - ahfgrady(3,2:ny-1,2:nz-1)
      ahfgradz(1,2:ny-1,2:nz-1) = 2.0D0*ahfgradz(2,2:ny-1,2:nz-1)
     .   - ahfgradz(3,2:ny-1,2:nz-1)
      ahfgradn(1,2:ny-1,2:nz-1) = 2.0D0*ahfgradn(2,2:ny-1,2:nz-1)
     .   - ahfgradn(3,2:ny-1,2:nz-1)

      ahf_exp(nx,2:ny-1,2:nz-1)  = 2.0D0*ahf_exp(nx-1,2:ny-1,2:nz-1)
     .   - ahf_exp(nx-2,2:ny-1,2:nz-1)
      ahfgradx(nx,2:ny-1,2:nz-1) = 2.0D0*ahfgradx(nx-1,2:ny-1,2:nz-1)
     .   - ahfgradx(nx-2,2:ny-1,2:nz-1)
      ahfgrady(nx,2:ny-1,2:nz-1) = 2.0D0*ahfgrady(nx-1,2:ny-1,2:nz-1)
     .   - ahfgrady(nx-2,2:ny-1,2:nz-1)
      ahfgradz(nx,2:ny-1,2:nz-1) = 2.0D0*ahfgradz(nx-1,2:ny-1,2:nz-1)
     .   - ahfgradz(nx-2,2:ny-1,2:nz-1)
      ahfgradn(nx,2:ny-1,2:nz-1) = 2.0D0*ahfgradn(nx-1,2:ny-1,2:nz-1)
     .   - ahfgradn(nx-2,2:ny-1,2:nz-1)

!     Boundaries on y direction.

      ahf_exp(2:nx-1,1,2:nz-1)  = 2.0D0*ahf_exp(2:nx-1,2,2:nz-1)
     .   - ahf_exp(2:nx-1,3,2:nz-1)
      ahfgradx(2:nx-1,1,2:nz-1) = 2.0D0*ahfgradx(2:nx-1,2,2:nz-1)
     .   - ahfgradx(2:nx-1,3,2:nz-1)
      ahfgrady(2:nx-1,1,2:nz-1) = 2.0D0*ahfgrady(2:nx-1,2,2:nz-1)
     .   - ahfgrady(2:nx-1,3,2:nz-1)
      ahfgradz(2:nx-1,1,2:nz-1) = 2.0D0*ahfgradz(2:nx-1,2,2:nz-1)
     .   - ahfgradz(2:nx-1,3,2:nz-1)
      ahfgradn(2:nx-1,1,2:nz-1) = 2.0D0*ahfgradn(2:nx-1,2,2:nz-1)
     .   - ahfgradn(2:nx-1,3,2:nz-1)

      ahf_exp(2:nx-1,ny,2:nz-1)  = 2.0D0*ahf_exp(2:nx-1,ny-1,2:nz-1)
     .   - ahf_exp(2:nx-1,ny-2,2:nz-1)
      ahfgradx(2:nx-1,ny,2:nz-1) = 2.0D0*ahfgradx(2:nx-1,ny-1,2:nz-1)
     .   - ahfgradx(2:nx-1,ny-2,2:nz-1)
      ahfgrady(2:nx-1,ny,2:nz-1) = 2.0D0*ahfgrady(2:nx-1,ny-1,2:nz-1)
     .   - ahfgrady(2:nx-1,ny-2,2:nz-1)
      ahfgradz(2:nx-1,ny,2:nz-1) = 2.0D0*ahfgradz(2:nx-1,ny-1,2:nz-1)
     .   - ahfgradz(2:nx-1,ny-2,2:nz-1)
      ahfgradn(2:nx-1,ny,2:nz-1) = 2.0D0*ahfgradn(2:nx-1,ny-1,2:nz-1)
     .   - ahfgradn(2:nx-1,ny-2,2:nz-1)

!     Boundaries on z direction.

      ahf_exp(2:nx-1,2:ny-1,1)  = 2.0D0*ahf_exp(2:nx-1,2:ny-1,2)
     .   - ahf_exp(2:nx-1,2:ny-1,3)
      ahfgradx(2:nx-1,2:ny-1,1) = 2.0D0*ahfgradx(2:nx-1,2:ny-1,2)
     .   - ahfgradx(2:nx-1,2:ny-1,3)
      ahfgrady(2:nx-1,2:ny-1,1) = 2.0D0*ahfgrady(2:nx-1,2:ny-1,2)
     .   - ahfgrady(2:nx-1,2:ny-1,3)
      ahfgradz(2:nx-1,2:ny-1,1) = 2.0D0*ahfgradz(2:nx-1,2:ny-1,2)
     .   - ahfgradz(2:nx-1,2:ny-1,3)
      ahfgradn(2:nx-1,2:ny-1,1) = 2.0D0*ahfgradn(2:nx-1,2:ny-1,2)
     .   - ahfgradn(2:nx-1,2:ny-1,3)

      ahf_exp(2:nx-1,2:ny-1,nz)  = 2.0D0*ahf_exp(2:nx-1,2:ny-1,nz-1)
     .   - ahf_exp(2:nx-1,2:ny-1,nz-2)
      ahfgradx(2:nx-1,2:ny-1,nz) = 2.0D0*ahfgradx(2:nx-1,2:ny-1,nz-1)
     .   - ahfgradx(2:nx-1,2:ny-1,nz-2)
      ahfgrady(2:nx-1,2:ny-1,nz) = 2.0D0*ahfgrady(2:nx-1,2:ny-1,nz-1)
     .   - ahfgrady(2:nx-1,2:ny-1,nz-2)
      ahfgradz(2:nx-1,2:ny-1,nz) = 2.0D0*ahfgradz(2:nx-1,2:ny-1,nz-1)
     .   - ahfgradz(2:nx-1,2:ny-1,nz-2)
      ahfgradn(2:nx-1,2:ny-1,nz) = 2.0D0*ahfgradn(2:nx-1,2:ny-1,nz-1)
     .   - ahfgradn(2:nx-1,2:ny-1,nz-2)

!     Synchronize.

      call CCTK_SyncGroup(ierr,cctkGH,"ahfinder::ahfgradient")
      call CCTK_SyncGroup(ierr,cctkGH,"ahfinder::ahfinderexp")

      call CartSymGN(ierr,cctkGH,"ahfinder::ahfgradient")
      call CartSymGN(ierr,cctkGH,"ahfinder::ahfinderexp")


!     ***************
!     ***   END   ***
!     ***************

      return
      end

```

AHFinder_flow.F:
```
/*@@
  @file      AHFinder_flow.F
  @date      November 1998
  @author    Miguel Alcubierre
  @desc 
             Master routine to control the iterations for
             the flow algorithm.

             The flow algorithm used here is that of Carsten Gunlach:
             Phys. Rev. D 57, 863 (1998).

  @enddesc 
@@*/

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

      subroutine AHFinder_flow(CCTK_ARGUMENTS,rmx,status,logf)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS 

      logical status,new,update

      integer i,j,l,m
      integer itmax

      CCTK_REAL rmx,ahftol
      CCTK_REAL A,B
      CCTK_REAL ahfsum,ahfdiff,ahfdiff_old
      CCTK_REAL reldiff
      CCTK_REAL maxchange,minchange
      CCTK_REAL zero,one
      CCTK_REAL dd,aux

      character(len=200) :: logf

!     Description of variables:
!
!     new         Flag to indicate that stepsize has changed.
!     update      Flag to indicate if coefficients will be updated.
!
!     i,j,l,m     Counters.
!
!     itmax       Maximum number of iterations.
!
!     ahftol      Tolerance used to decide if we have converged.
!
!     A,B         Flow parameters.
!
!     hw          Weigth of `H' flow (see Carsten's paper).
!     cw          Weigth of `C' flow (see Carsten's paper).
!     nw          Weigth of `N' flow (see Carsten's paper).
!
!     ahfsum      Square root of the sum of the squares of the
!                 expansion coefficients.
!
!     ahfdiff     Square root of the sum of the squares of the
!                 change in the coefficients.
!
!     rediff      Relative difference between having done one large
!                 step and two small ones.
!
!     maxchange   A value of "reldiff" larger than this forces a
!                 reduction of the stepsize.
!
!     minchange   A value of "reldiff" smaller than this forces an
!                 increase of the stepsize.
!
!     dd          Maximum of (dx,dy,dz).


!     ***************************
!     ***   DEFINE  NUMBERS   ***
!     ***************************

      zero = 0.0D0
      one  = 1.0D0

      dd = max(dx,dy,dz)


!     ***************************
!     ***   FIND PARAMETERS   ***
!     ***************************

      A = ahf_flowa
      B = ahf_flowb

      hw = ahf_flowh
      cw = ahf_flowc
      nw = ahf_flown

      maxchange = ahf_maxchange
      minchange = ahf_minchange


!     *******************************
!     ***   MAIN ITERATION LOOP   ***
!     *******************************

!     Find itmax and ahftol.

      itmax  = ahf_flowiter
      ahftol = ahf_flowtol

!     Start the iterations.

      do i=1,itmax

!        Save the old values of the coefficients.

         c0_old = c0
         cc_old = cc
         cs_old = cs

!        In order to adapt the stepsize, I do two steps
!        with the current stepsize, and compare them with
!        one step with double the stepsize.

         do j=1,2

            ahfsum  = zero
            ahfdiff = zero


!           ************************************
!           ***   FIND SPECTRAL COMPONENTS   ***
!           ************************************

            call AHFinder_fun(CCTK_ARGUMENTS)
            call AHFinder_exp(CCTK_ARGUMENTS)
            call AHFinder_int(CCTK_ARGUMENTS)


!           *****************************
!           ***   CHECK ERROR FLAGS   ***
!           *****************************

            update = .true.

!           If interror is true there was an error in the integral.
!           There are two possibilities here:

!           1) This is the first of the two small steps (j=1).
!              We then went out of bounds in the previous iteration,
!              so there is nothing we can do to fix it.

            if (interror.and.(j.eq.1)) then

!              We can be out of bounds for three reasons:

!              a) The radius is negative somewhere.  This can mean
!                 one of two things:
!
!                 * There is no horizon, and the flow has reached
!                   the origin.
!
!                 * The origin for our expansion is outside the horizon.
!                   This can happen if the black-hole is not centered,
!                   or if we have more than one horizon.

               if (interror1.ne.0) then

                  write(*,*)
                  write(*,*) 'Negative radius.'
                  return

!              b) We are out of the computational domain, pity.

               else if (interror2.ne.0) then

                  write(*,*)
                  write(*,*) 'Out of bounds, giving up.'
                  return

!              c) We are inside the mask.

               else if (interror3.ne.0) then

                  write(*,*)
                  write(*,*) 'Inside mask, giving up.'
                  return

!              We should never get here!

               else

                  write(*,*)
                  write(*,*) 'PANIC! Something is very wrong.'
                  return

               end if

!           2) This is the second of the two small steps (j=2).
!              We can still try to reduce the stepsize and start
!              the iteration again.  We then return the coefficients
!              to their original values and, and do not update them.
!
!              Since I will not update the coefficients, I need to
!              assign values to "afhsum" and "ahfdiff". In order
!              to force a reduction of the step size, I assign
!              a very large number to "ahfdiff", which will make
!              "reldiff" close to 1.0, far too large.  I also
!              assign a value of 1.0 to "ahfsum", so it is much
!              smaller than "ahfdiff".  This is important in order
!              to prevent the algorithm from thinking we are done
!              (see below for termination criteria).

            else if (interror) then

               interror = .false.

               c0 = c0_old
               cc = cc_old
               cs = cs_old

               ahfsum   = one
               ahfdiff  = 1.0D10

               update = .false.

            end if


!           ****************************************
!           ***   UPDATE SPECTRAL COEFFICIENTS   ***
!           ****************************************

            if (update) then

!              Update c0.

               do l=0,lmax,1+stepz
                  aux = c0(l)
                  c0(l) = aux - A/(one + B*dble(l)*(dble(l) + one))
     .               *(hw*hflow0(l) + cw*cflow0(l) + nw*nflow0(l))
                  ahfsum  = ahfsum + c0_old(l)**2
                  ahfdiff = ahfdiff + (c0(l) - c0_old(l))**2
               end do

!              Update {cc,cs}.

               if (nonaxi) then

!                 Update cc(l,m).

                  do l=1,lmax
                     do m=1+stepx,l,1+stepx
                        if (stepz*mod(l-m,2).eq.0) then
                           aux = cc(l,m)
                           cc(l,m) = aux - A/(one
     .                          + B*dble(l)*(dble(l) + one))
     .                          *(hw*hflowc(l,m) + cw*cflowc(l,m)
     .                          + nw*nflowc(l,m))
                           ahfsum  = ahfsum + cc_old(l,m)**2
                           ahfdiff = ahfdiff + (cc(l,m)-cc_old(l,m))**2
                        end if
                     end do
                  end do

!                 Update cs(l,m).

                  if (.not.refy) then
                     do l=1,lmax
                        do m=1,l,1+stepx
                           if (stepz*mod(l-m,2).eq.0) then
                              cs(l,m) = cs(l,m) - A/(one
     .                           + B*dble(l)*(dble(l) + one))
     .                           *(hw*hflows(l,m) + cw*cflows(l,m)
     .                           + nw*nflows(l,m))
                              ahfsum  = ahfsum + cs_old(l,m)**2
                              ahfdiff = ahfdiff + (cs(l,m)-cs_old(l,m))**2
                           end if
                        end do
                     end do
                  end if

               end if

               ahfsum  = sqrt(ahfsum)
               ahfdiff = sqrt(ahfdiff)

!              If this is the first of the two small steps, save
!              twice the difference.  Why twice?  Because this would
!              have been the resulting difference if we had done only
!              one step that was twice as big.

               if (j.eq.1) then
                  ahfdiff_old = 2.0D0*ahfdiff
               end if

            end if

         end do


!        ************************************
!        ***   FIND RELATIVE DIFFERENCE   ***
!        ************************************

!        Here we find the relative difference between having done two
!        small steps and one large step.

         reldiff = abs(ahfdiff - ahfdiff_old)
     .           / (abs(ahfdiff) + abs(ahfdiff_old))


!        Open logfile.

         logf = filestr(1:nfile)//"/ahf_logfile"

         if (logfile.and.(myproc.eq.0)) then
            open(11,file=logf,form='formatted',status='old',
     .      position='append')
         end if

!        ***************************
!        ***   ADJUST STEPSIZE   ***
!        ***************************

         new = .false.

!        If the relative difference is too large, we reduce the
!        stepsize for the next iteration.

         if ((reldiff.gt.maxchange).or.
     .       (ahfdiff.gt.maxchange*ahfsum)) then

            new = .true.
            A = 0.5D0*A

            if (veryver) then
               write(*,*)
               write(*,"(A15,ES14.6)") ' New stepsize =',A
            end if

            if (logfile) then
               write(11,*)
               write(11,"(A15,ES14.6)") ' New stepsize =',A
            end if

!        If the difference is too small, we can safely increase
!        the stepsize for the next iteration.

         else if (reldiff.lt.minchange) then

            new = .true.
            A = 2.0D0*A

            if (veryver) then
               write(*,*)
               write(*,"(A15,ES14.6)") ' New stepsize =',A
            end if

            if (logfile) then
               write(11,*)
               write(11,"(A15,ES14.6)") ' New stepsize =',A
            end if

         end if
         

!        ******************************************
!        ***   LOGFILE AND MESSAGES TO SCREEN   ***
!        ******************************************

!        Write messages.

         if (myproc.eq.0) then

            if (veryver) then

               write(*,*)
               write(*,*)
               write(*,"(A16,I3)") ' FLOW ITERATION ',i

               if (intarea.ne.zero) then
                  aux = one/intarea
               else
                  aux = one
               end if

               write(*,*)
               write(*,"(A21,ES14.6)") ' Surface area       =',intarea
               write(*,"(A21,ES14.6)") ' Mean value of H    =',aux*intexp
               write(*,"(A21,ES14.6)") ' Mean value of H^2  =',aux*intexp2
               write(*,"(A21,ES14.6)") ' ahfdiff/ahfsum     =',ahfdiff/ahfsum

               if (offset) then
                  write(*,*)
                  write(*,"(A6,ES14.6)") ' xc  =',xc
                  write(*,"(A6,ES14.6)") ' yc  =',yc
                  write(*,"(A6,ES14.6)") ' zc  =',zc
               end if

               write(*,*)
               write(*,"(A20)") ' Shape coefficients:'
               write(*,*)

               write(*,"(A4,I2,A3,ES14.6)") ' c0(',0,') =',c0(0)

               do l=1+stepz,lmax,1+stepz
                  write(*,"(A4,I2,A3,ES14.6)") ' c0(',l,') =',c0(l)
               end do

            end if

            if (logfile) then

               write(11,*)
               write(11,"(A16,I3)") ' FLOW ITERATION ',i

               if (intarea.ne.zero) then
                  aux = one/intarea
               else
                  aux = one
               end if

               write(11,*)
               write(11,"(A21,ES14.6)") ' Surface area       =',intarea
               write(11,"(A21,ES14.6)") ' Mean value of H    =',aux*intexp
               write(11,"(A21,ES14.6)") ' Mean value of H^2  =',aux*intexp2
               write(11,"(A21,ES14.6)") ' ahfdiff/ahfsum     =',ahfdiff/ahfsum

               if (offset) then
                  write(11,*)
                  write(11,"(A6,ES14.6)") ' xc  =',xc
                  write(11,"(A6,ES14.6)") ' yc  =',yc
                  write(11,"(A6,ES14.6)") ' zc  =',zc
               end if

               write(11,*)
               write(11,"(A20)") ' Shape coefficients:'
               write(11,*)

               write(11,"(A4,I2,A3,ES14.6)") ' c0(',0,') =',c0(0)

               do l=1+stepz,lmax,1+stepz
                  write(11,"(A4,I2,A3,ES14.6)") ' c0(',l,') =',c0(l)
               end do

            end if

            if (nonaxi) then

               if (.not.refy) then

                  if (veryver) then

                     write(*,*)

                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(*,"(A4,I2,A1,I2,A4,ES14.6)") ' cc(',
     .                        l,',',m,')  =',cc(l,m)
                           end if
                        end do
                     end do
                     write(*,*)
                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(*,"(A4,I2,A1,I2,A4,ES14.6)") ' cs(',
     .                        l,',',m,')  =',cs(l,m)
                           end if
                        end do
                     end do

                  end if

                  if (logfile) then

                     write(11,*)

                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(11,"(A4,I2,A1,I2,A4,ES14.6)") ' cc(',
     .                        l,',',m,')  =',cc(l,m)
                           end if
                        end do
                     end do
                     write(11,*)
                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(11,"(A4,I2,A1,I2,A4,ES14.6)") ' cs(',
     .                        l,',',m,')  =',cs(l,m)
                           end if
                        end do
                     end do

                  end if

               else

                  if (veryver) then

                     write(*,*)

                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(*,"(A4,I2,A1,I2,A4,ES14.6)") ' cc(',
     .                        l,',',m,')  =',cc(l,m)
                           end if
                        end do
                     end do

                  end if

                  if (logfile) then

                     write(11,*)

                     do l=1,lmax
                        do m=1,l
                           if (stepz*mod(l-m,2).eq.0) then
                              write(11,"(A4,I2,A1,I2,A4,ES14.6)") ' cc(',
     .                        l,',',m,')  =',cc(l,m)
                           end if
                        end do
                     end do

                  end if

               end if
            end if
         end if

!        Close logfile.

         if (logfile.and.(myproc.eq.0)) then
            close(11)
         end if


!        ***********************************
!        ***   CHECK IF WE HAVE FAILED   ***
!        ***********************************

!        The finder needs a way to give up if there is no
!        horizon.  At the moment, the way in which I do this
!        is that I just give up if the monopole term is of
!        the order of 2 grid points in size.  Maybe this
!        could be improved on?

         if (c0(0).lt.2.0D0*dd) then
            write(*,*)
            write(*,*) 'Surface radius is too small, giving up.'
            return
         end if


!        ********************************************
!        ***   CHECK IF WE HAVE FOUND A HORIZON   ***
!        ********************************************

!        For this I use a straigthforward test to check if the
!        change in the surface is below a given tolerance.  This
!        usually works well, but if the tolerance is too small then
!        the convergence becomes very slow.  Also, since I use an
!        adaptive stepsize, I run the risk of having a small change
!        simply because the stepsize itself is very small, and not
!        because we found a horizon.  This can happen is the tolerance
!        is not small enough.  So we have a balancing act here.

         if (ahfdiff.lt.ahftol*ahfsum) then
            status = .true.
            return
         end if

      end do


!     ******************************
!     ***   TOO MANY IERATIONS   ***
!     ******************************

!     If we ever get here, we did too many iterations and
!     failed to converge.

      status = .true.

      if (veryver) then
         write(*,*)
         write(*,*) 'Too many iterations'
      end if


!     ***************
!     ***   END   ***
!     ***************

      end subroutine AHFinder_flow

```

AHFinder_output.F:
```
/*@@
  @file      AHFinder_output.F
  @date      Fri 2 Aug 2001
  @author    Thomas Radke
  @desc 
             Does the output of AHFinder data into files.
  @enddesc 
@@*/

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

      subroutine AHFinder_InitOutput(CCTK_ARGUMENTS)
      use AHFinder_dat
      implicit none
      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS
      DECLARE_CCTK_FUNCTIONS
      
      character(len=3) ::   ext
      character(len=200) :: almf,areaf,massf,radf,circeqf,merip1f,merip2f
      character(len=200) :: asymxf,asymyf,asymzf
      character(len=200) :: disf
      character(len=200) :: gaussf, gauss0f, gauss1f, gauss2f

      myproc = CCTK_MyProc(cctkGH)
      if (myproc.ne.0) then
        return
      end if

!     ****************************
!     ***   BUILD FILE NAMES   ***
!     ****************************

      call CCTK_FortranString(nfile,out_dir,filestr)

c     some compilers cannot trim an empty string, so we add at least one char
      if (find3) then
         ext = "_" // char(ichar('0') + mfind - 1) // "."
      else
         ext = "."
      end if

      almf = filestr(1:nfile) // "/ahf_coeff" // trim(ext) // "alm"
      areaf = filestr(1:nfile) // "/ahf_area" // trim(ext) // "tl"
      massf = filestr(1:nfile) // "/ahf_mass" // trim(ext) // "tl"
      radf  = filestr(1:nfile) // "/ahf_rad" // trim(ext) // "tl"

      circeqf = filestr(1:nfile) // "/ahf_circ_eq" // trim(ext) // "tl"
      merip1f = filestr(1:nfile) // "/ahf_meri_p1" // trim(ext) // "tl"
      merip2f = filestr(1:nfile) // "/ahf_meri_p2" // trim(ext) // "tl"

      asymxf = filestr(1:nfile) // "/ahf_asymx" // trim(ext) // "tl"
      asymyf = filestr(1:nfile) // "/ahf_asymy" // trim(ext) // "tl"
      asymzf = filestr(1:nfile) // "/ahf_asymz" // trim(ext) // "tl"

      disf = filestr(1:nfile) // "/ahf_d12" // trim(ext) // "tl"

      gaussf = filestr(1:nfile) // "/ahf.gauss"
      gauss0f = filestr(1:nfile) // "/ahf_0.gauss"
      gauss1f = filestr(1:nfile) // "/ahf_1.gauss"
      gauss2f = filestr(1:nfile) // "/ahf_2.gauss"


      open(11,file=massf,form='formatted',status='replace')
      write(11,"(A14)") '" Horizon mass'
      close(11)

      open(11,file=radf,form='formatted',status='replace')
      write(11,"(A26)") '" Horizon radius'
      close(11)

      open(11,file=circeqf,form='formatted',status='replace')
      write(11,"(A26)") '" Equatorial circumference'
      close(11)

      open(11,file=merip1f,form='formatted',status='replace')
      write(11,"(A27)") '" Length of meridian, phi=0'
      close(11)

      open(11,file=merip2f,form='formatted',status='replace')
      write(11,"(A30)") '" Length of meridian, phi=pi/2'
      close(11)

      open(11,file=areaf,form='formatted',status='replace')
      write(11,"(A14)") '" Horizon area'
      close(11)

      open(11,file=asymxf,form='formatted',status='replace')
      write(11,"(A29)") '" Asymmetries on x reflection'
      close(11)

      open(11,file=asymyf,form='formatted',status='replace')
      write(11,"(A29)") '" Asymmetries on y reflection'
      close(11)

      open(11,file=asymzf,form='formatted',status='replace')
      write(11,"(A29)") '" Asymmetries on z reflection'
      close(11)

      open(11,file=almf,form='formatted',status='replace')
      write(11,"(A21)")    '# Radial coefficients'
      write(11,"(A1)")     '#'
      close(11)

      open(11,file=disf,form='formatted',status='replace')
      write(11,"(A18)") '" Horizon distance'
      close(11)

      if (find3) then
        call AHFinder_WriteGaussHeader(CCTK_PASS_FTOF, gauss0f)
        call AHFinder_WriteGaussHeader(CCTK_PASS_FTOF, gauss1f)
        call AHFinder_WriteGaussHeader(CCTK_PASS_FTOF, gauss2f)
      else
        call AHFinder_WriteGaussHeader(CCTK_PASS_FTOF, gaussf)
      end if

      end subroutine AHFinder_InitOutput



      
      subroutine AHFinder_WriteGaussHeader(CCTK_ARGUMENTS, filename)
      use AHFinder_dat
      implicit none
      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS

      character(len=200) :: filename

      call AHFinder_SetReflections(CCTK_ARGUMENTS)

      open(11,file=filename,form='formatted', status='replace')
      
      write(11,"(A20)") '# GAUSSIAN CURVATURE'
      write(11,"(A1)")  '#'
      write(11,"(A35)") '# The data is written in a loop as:'
      write(11,"(A1)")  '#'
      write(11,"(A17)") '# do i=1,ntheta'
      write(11,"(A18)") '#    do j=1,nphi'
      write(11,"(A27)") '#       write gaussian(i,j)'
      write(11,"(A11)") '#    end do'
      write(11,"(A8)")  '# end do'
      write(11,"(A1)")  '#'
      write(11,"(A40)") '# theta and phi are subdivided uniformly'
      write(11,"(A26)") '# according to symmetries:'
      write(11,"(A1)")  '#'
      write(11,"(A36)") '# phi=[0,2 pi]   (refx=refy=.false.)'
      write(11,"(A44)") '# phi=[0,pi]     (refx=.false., refy=.true.)'
      write(11,"(A35)") '# phi=[0,pi/2]   (refx=refy=.true.)'
      write(11,"(A1)")  '#'
      write(11,"(A31)") '# theta=[0,pi]   (refz=.false.)'
      write(11,"(A30)") '# theta=[0,pi/2] (refz=.true.)'
      write(11,"(A1)")  '#'

      write(11,"(A9,L1)")  '# refx = ',refx
      write(11,"(A9,L1)")  '# refy = ',refy
      write(11,"(A9,L1)")  '# refz = ',refz
      write(11,"(A1)")     '#'
      write(11,"(A11,I7)") '# ntheta = ',(ahf_ntheta+1)
      write(11,"(A11,I7)") '# nphi   = ',(ahf_nphi+1)

      close(11)

      end subroutine AHFinder_WriteGaussHeader




      subroutine AHFinder_Output(CCTK_ARGUMENTS, report, status, horizon, mtype, intarea_h)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS

      integer mtype
      logical report, status, horizon
      logical massf_exists, radf_exists, circeqf_exists
      logical merip1f_exists, merip2f_exists, areaf_exists
      logical asymxf_exists, asymyf_exists, asymzf_exists, almf_exists
      CCTK_REAL intarea_h

      integer l, m, ierror
      character(len=3) ::   ext
      character(len=200) :: almf,areaf,massf,radf,circeqf,merip1f,merip2f
      character(len=200) :: asymxf,asymyf,asymzf
      character(len=200) :: options


!     ****************************
!     ***   BUILD FILE NAMES   ***
!     ****************************

c     some compilers cannot trim an empty string, so we add at least one char
      if (find3) then
         ext = "_" // char(ichar('0') + mfind - 1) // "."
      else
         ext = "."
      end if

      almf = filestr(1:nfile) // "/ahf_coeff" // trim(ext) // "alm"
      areaf = filestr(1:nfile) // "/ahf_area" // trim(ext) // "tl"
      massf = filestr(1:nfile) // "/ahf_mass" // trim(ext) // "tl"
      radf  = filestr(1:nfile) // "/ahf_rad" // trim(ext) // "tl"

      circeqf = filestr(1:nfile) // "/ahf_circ_eq" // trim(ext) // "tl"
      merip1f = filestr(1:nfile) // "/ahf_meri_p1" // trim(ext) // "tl"
      merip2f = filestr(1:nfile) // "/ahf_meri_p2" // trim(ext) // "tl"

      asymxf = filestr(1:nfile) // "/ahf_asymx" // trim(ext) // "tl"
      asymyf = filestr(1:nfile) // "/ahf_asymy" // trim(ext) // "tl"
      asymzf = filestr(1:nfile) // "/ahf_asymz" // trim(ext) // "tl"


!     *********************************
!     ***   OUTPUT GRID FUNCTIONS   ***
!     *********************************

      if (ahf_2Doutput.ne.0) then
         if (.not.find3) then
            call CCTK_OutputVarByMethod(ierror,cctkGH,
     .           "ahfinder::ahfgrid","IOFlexIO_2D")
            call CCTK_OutputVarByMethod(ierror,cctkGH,
     .           "ahfinder::ahf_exp","IOFlexIO_2D")
         else if (mfind.eq.3) then
            call CCTK_OutputVarByMethod(ierror,cctkGH,
     .           "ahfinder::ahfgrid3","IOFlexIO_2D")
            call CCTK_OutputVarByMethod(ierror,cctkGH,
     .           "ahfinder::ahf_exp3","IOFlexIO_2D")
         end if
         if (ierror < 0) then
           call CCTK_WARN(2, "Failed to output 2D data! For this to work, you must have IOFlexIO enabled")
         end if
      end if

      if (ahf_3Doutput.ne.0) then
         if (.not.find3) then
            call CCTK_OutputVarByMethod(ierror,cctkGH,
     .           "ahfinder::ahfgrid","IOFlexIO_3D")
            call CCTK_OutputVarByMethod(ierror,cctkGH,
     .           "ahfinder::ahf_exp","IOFlexIO_3D")
         else if (mfind.eq.3) then
            call CCTK_OutputVarByMethod(ierror,cctkGH,
     .           "ahfinder::ahfgrid","IOFlexIO_3D")
            call CCTK_OutputVarByMethod(ierror,cctkGH,
     .           "ahfinder::ahf_exp","IOFlexIO_3D")
         end if
         if (ierror < 0) then
           call CCTK_WARN(2, "Failed to output 3D data! For this to work, you must have IOFlexIO enabled")
         end if
      end if


!     **************************************************
!     ***   OUTPUT ASCII DATA ONLY ON PROCESSOR 0    ***
!     **************************************************

      if (myproc.eq.0) then

!        Mass.
        
        inquire(file=massf, exist=massf_exists)
        if (massf_exists) then
          open(11,file=massf,form='formatted',status='old',position='append')
        else
          open(11,file=massf,form='formatted',status='replace')
          write(11,"(A14)") '" Horizon mass'
        end if

        if (status.and.report) then
           out_mass = 0.141047396D0 * sqrt(intarea_h)
        else
           out_mass = 0.0
        end if
        write(11,"(2ES14.6)") cctk_time, out_mass

        close(11)

!        Radius.

        inquire(file=radf, exist=radf_exists)
        if (radf_exists) then
          open(11,file=radf,form='formatted',status='old',position='append')
        else
          open(11,file=radf,form='formatted',status='replace')
          write(11,"(A26)") '" Horizon radius'
        end if

        if (status.and.report) then
           out_radius = c0(0)
        else
           out_radius = 0.0
        end if
        write(11,"(2ES14.6)") cctk_time, out_radius

        close(11)

!        Equatorial circumference.

        inquire(file=circeqf, exist=circeqf_exists)
        if (circeqf_exists) then
          open(11,file=circeqf,form='formatted',status='old',position='append')
        else
          open(11,file=circeqf,form='formatted',status='replace')
          write(11,"(A26)") '" Equatorial circumference'
        end if

        if (status.and.report) then
           out_perimeter = circ_eq
        else
           out_perimeter = 0.0
        end if
        write(11,"(2ES14.6)") cctk_time, out_perimeter

        close(11)

!        Meridians.

        inquire(file=merip1f, exist=merip1f_exists)
        if (merip1f_exists) then
          open(11,file=merip1f,form='formatted',status='old',position='append')
        else
          open(11,file=merip1f,form='formatted',status='replace')
          write(11,"(A27)") '" Length of meridian, phi=0'
        end if

        if (status.and.report) then
           out_meridian1 = meri_p1
        else
           out_meridian1 = 0.0
        end if
        write(11,"(2ES14.6)") cctk_time, out_meridian1

        close(11)

        inquire(file=merip2f, exist=merip2f_exists)
        if (merip2f_exists) then
          open(11,file=merip2f,form='formatted',status='old', position='append')
        else
          open(11,file=merip2f,form='formatted',status='replace')
          write(11,"(A30)") '" Length of meridian, phi=pi/2'
        end if

        if (status.and.report) then
           out_meridian2 = meri_p2
        else
           out_meridian2 = 0.0
        end if
        write(11,"(2ES14.6)") cctk_time, out_meridian2

        close(11)

!        Area.
        
        inquire(file=areaf, exist=areaf_exists)
        if (areaf_exists) then
          open(11,file=areaf,form='formatted',status='old',position='append')
        else
          open(11,file=areaf,form='formatted',status='replace')
          write(11,"(A14)") '" Horizon area'
        end if

        if (status.and.report) then
           out_area = intarea_h
        else
           out_area = 0.0
        end if
        write(11,"(2ES14.6)") cctk_time, out_area

        close(11)

!        Asymmetries in x.  Coefficients cc with odd m, and
!        coefficients cs with even m indicate asymmetries
!        on refelction x<->-x.

        inquire(file=asymxf, exist=asymxf_exists)
        if (asymxf_exists) then
          open(11,file=asymxf,form='formatted',status='old', position='append')
        else
          open(11,file=asymxf,form='formatted',status='replace')
          write(11,"(A29)") '" Asymmetries on x reflection'
        end if

        out_asymx = 0.0D0
        if (status.and.report.and..not.refx) then
           do l=1,lmax
              do m=1,l
                 if (mod(m,2).ne.0) then
                    out_asymx = out_asymx + abs(cc(l,m))
                 else
                    out_asymx = out_asymx + abs(cs(l,m))
                 end if
              end do
           end do
           out_asymx = out_asymx / c0(0)
        end if
        write(11,"(2ES14.6)") cctk_time, out_asymx

        close(11)

!        Asymmetries in y.  Any cs coefficient different from
!        zero indicates asymmetries on reflection y<->-y.

        inquire(file=asymyf, exist=asymyf_exists)
        if (asymyf_exists) then
          open(11,file=asymyf,form='formatted',status='old', position='append')
        else
          open(11,file=asymyf,form='formatted',status='replace')
          write(11,"(A29)") '" Asymmetries on y reflection'
        end if

        out_asymy = 0.0D0
        if (status.and.report.and..not.refy) then
           do l=1,lmax
              do m=1,l
                 out_asymy = out_asymy + abs(cs(l,m))
              end do
           end do
           out_asymy = out_asymy / c0(0)
        end if
        write(11,"(2ES14.6)") cctk_time, out_asymy

        close(11)

!        Asymmetries in z. Any coefficient c0 with odd l,
!        or any coefficient cc and cs with odd (l-m) indicate
!        asymmetries on reflection z<->-z.

        inquire(file=asymzf, exist=asymzf_exists)
        if (asymzf_exists) then
          open(11,file=asymzf,form='formatted',status='old',position='append')
        else
          open(11,file=asymzf,form='formatted',status='replace')
          write(11,"(A29)") '" Asymmetries on z reflection'
        end if

        out_asymz = 0.0D0
        if (status.and.report.and..not.refz) then
           do l=1,lmax
              if (mod(l,2).ne.0) out_asymz = out_asymz + abs(c0(l))
              do m=1,l
                 if (mod(l-m,2).ne.0) then
                    out_asymz = out_asymz + abs(cc(l,m)) + abs(cs(l,m))
                 end if
              end do
           end do
           out_asymz = out_asymz / c0(0)
        end if
        write(11,"(2ES14.6)") cctk_time, out_asymz

        close(11)

!       Expansion coefficients.

        inquire(file=almf, exist=almf_exists)
        if (almf_exists) then
          open(11,file=almf,form='formatted',status='old',position='append')
        else
          open(11,file=almf,form='formatted',status='replace')
          write(11,"(A21)")    '# Radial coefficients'
          write(11,"(A1)")     '#'
        end if

        write(11,"(A12,I4)") '# Time step ',cctk_iteration
        write(11,"(A7,ES14.6)") '# Time ',cctk_time
        write(11,"(A7,I4)")  '# Call ',ahf_ncall

        if (status.and.report) then
           if (mtype.eq.1) then
              if (horizon) then
                 write(11,"(A30,I4)") '# Surface found: Outer horizon'
              else
                 write(11,"(A31,I4)") '# Surface found: Outer horizon?'
              end if
           else if (mtype.eq.2) then
              if (horizon) then
                 write(11,"(A30,I4)") '# Surface found: Inner horizon'
              else
                 write(11,"(A31,I4)") '# Surface found: Inner horizon?'
              end if
           else if (mtype.eq.3) then
              if (horizon) then
                 write(11,"(A34,I4)") '# Surface found: Marginal horizon?'
              else
                 write(11,"(A32,I4)") '# Surface found: Trapped surface'
              end if
           else if (mtype.eq.4) then
              if (horizon) then
                 write(11,"(A34,I4)") '# Surface found: Marginal horizon?'
              else
                 write(11,"(A30,I4)") '# Surface found: Not a horizon'
              end if
           end if

           out_centerx = xc
           out_centery = yc
           out_centerz = zc

           write(11,"(A15,3ES14.6)") '# centered on: ', out_centerx, out_centery, out_centerz
  
           write(11,"(A1)")  '#'
           write(11,"(A22)") '#     a_lm       l   m'
           write(11,"(A1)")  '#'

           write(11,"(ES14.6,2I4)") c0(0),0,0

           if (lmax .gt. 0) then
              out_c0 = c0(1:)
              out_cs = cs
              out_cc = cc

              do l=1,lmax
                 do m=l,1,-1
                    write(11,"(ES14.6,2I4)") out_cs(l,m),l,-m
                 end do
                 write(11,"(ES14.6,2I4)") out_c0(l),l,0
                 do m=1,l
                    write(11,"(ES14.6,2I4)") out_cc(l,m),l,m
                 end do
              end do
           end if
          write(11,*)
        else
           write(11,"(A18,I4)") '# No surface found'
        end if

        close(11)

      end if

!     ***********************************************
!     ***   OUTPUT AHFINDER DATA IN HDF5 FORMAT   ***
!     ***********************************************

      options = "mfind=" // char(48 + mfind) // " mtype=" // char(48 + mtype)
      if (status) then
         options = options(1:15) // " status=1"
      else
         options = options(1:15) // " status=0"
      end if
      if (horizon) then
         options = options(1:24) // " horizon=1"
      else
         options = options(1:24) // " horizon=0"
      end if

      if (ahf_HDF5output.ne.0) then
        call CCTK_OutputVarByMethod (ierror, cctkGH, options, "IOAHFinderHDF5")
        if (ierror .ne. 0) then
           call CCTK_WARN (1, 'Error calling I/O method "IOAHFinderHDF5" (I/O method not activated ?)')
        end if
      end if


      end subroutine AHFinder_Output

```

AHFinder_ParamCheck.F90:
```
!  @@
!  @file      ParamCheck.F90
!  @date      Mon Apr 29 17:51:25 2002
!  @author    Peter Diener
!  @desc 
!  Parameter checking stuff for AHFinder
!  @enddesc
!  @version $Header$
! @@

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

! CCTK_FILEVERSION(CactusEinstein_AHFinder_ParamCheck_f)

!  @@
!  @routine    AHFinder_ParamCheck
!  @date       Thu Apr 29 17:51:25 2002
!  @author     Peter Diener
!  @desc 
!  Scheduled routine to detect invalid parameter settings.
!  @enddesc 
!  @calls     
!  @calledby   
!  @history 
!
!  @endhistory 
!
! @@

subroutine AHFinder_ParamCheck(CCTK_ARGUMENTS)
 
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_PARAMETERS
  DECLARE_CCTK_FUNCTIONS

  if ( ( .not. CCTK_EQUALS(metric_type,'physical') ) .and. &
       ( .not. CCTK_EQUALS(metric_type,'static conformal') ) ) then
    call CCTK_PARAMWARN('Unknown ADMBase::metric_type - known types are "physical" and "static conformal"')
  end if
end subroutine AHFinder_ParamCheck

```

AHFinder_dat.F:
```
/*@@
  @file      AHFinder_dat.F
  @date      April 1998
  @author    Miguel Alcubierre
  @desc 
             F90 module containing data to be shared by
             the different subroutines.

             For the meaning of the spectral components of
             the different flows see:

             C. Gundlach, Phys. Rev. D 57, 863 (1998).

  @enddesc 
@@*/

#include "cctk.h"

      module AHFinder_dat

      implicit none

      logical firstfun,firstleg,firstint
      logical nonaxi,refx,refy,refz,cartoon
      logical offset,wander
      logical minarea,flow,find_trapped_surface
      logical logfile,verbose,veryver,guessverbose
      logical interror,guessold
      logical find3,sloppy,inner,guess_absmin,manual_guess
      logical status_old,status_old_0,status_old_1,status_old_2

      integer lmax,stepx,stepy,stepz
      integer ntheta,nphi
      integer mfind,ahf_ncall
      integer nx,ny,nz
      integer nprocs,myproc,ierr

      CCTK_INT nfile
      CCTK_INT interror1,interror2,interror3
      CCTK_INT inside_min_count,inside_min_neg_count

      CCTK_REAL xc,yc,zc
      CCTK_REAL xmn,ymn,zmn,xmx,ymx,zmx
      CCTK_REAL xc_old,yc_old,zc_old
      CCTK_REAL intexp,intexp2,intexpdel2,intarea
      CCTK_REAL rhmax,rhmin
      CCTK_REAL circ_eq,meri_p1,meri_p2

      CCTK_REAL hw,cw,nw
      CCTK_REAL dx,dy,dz

      CCTK_REAL avgx,avgy,avgz

      CCTK_REAL, allocatable, dimension (:)   :: c0,c0_0,c0_1,c0_2,c0_old
      CCTK_REAL, allocatable, dimension (:,:) :: cc,cc_0,cc_1,cc_2,cc_old
      CCTK_REAL, allocatable, dimension (:,:) :: cs,cs_0,cs_1,cs_2,cs_old

      CCTK_REAL, allocatable, dimension (:)   :: hflow0,cflow0,nflow0
      CCTK_REAL, allocatable, dimension (:,:) :: hflowc,cflowc,nflowc
      CCTK_REAL, allocatable, dimension (:,:) :: hflows,cflows,nflows

      character(len=200) :: filestr

      data ahf_ncall / 0 /
      data status_old   / .false. /
      data status_old_0 / .false. /
      data status_old_1 / .false. /
      data status_old_2 / .false. /

      save ahf_ncall
      save c0,c0_0,c0_1,c0_2
      save cc,cc_0,cc_1,cc_2
      save cs,cs_0,cs_1,cs_2
      save status_old,status_old_0,status_old_1,status_old_2

!     Description of variables:
!
!     firstfun   First call to function FUNC?
!     firstleg   First call to function LEGEN?
!     firstint   First call to subroutine AHFinder_int?
!
!     nonaxi     Is the data non-axisymmetric?
!
!     refx       Reflection symmetry x->-x?
!
!     refy       Reflection symmetry y->-y?
!
!     refz       Reflection symmetry z->-z?
!
!     cartoon    Are we using cartoon_2d?
!
!     inner      Look for inner horizon?
!
!     sloppy     Sloppy initial guess?
!
!     offset     Is the center offset from the origin?
!     wander     Do we allow the center to wander?
!
!     minarea    Do we want to minimize area?
!
!     flow       Use fast flow algorithm instead of minimization?
!
!     logfile    Write log file?
!
!     verbose    Write messages to screen?
!
!     veryver    Write lots of messages to screen?
!
!     guessverbose   Write info on initial guess points?
!
!     lmax       Maximum number of terms in theta expansion.
!
!     stepx      1 if (refx=1), 0 otherwise.
!     stepy      1 if (refy=1), 0 otherwise.
!     stepz      1 if (refz=1), 0 otherwise.
!
!     ntheta     Number of subdivisions in theta.
!     nphi       Number of subdivisions in phi.
!
!     xc         Coordinate x of centre of surface.
!     yc         Coordinate y of centre of surface.
!     zc         Coordinate z of centre of surface.
!
!     xmn        Minimum value of x over the grid.
!     xmx        Maximum value of x over the grid.
!
!     ymn        Minimum value of y over the grid.
!     ymx        Maximum value of y over the grid.
!
!     zmn        Minimum value of z over the grid.
!     zmx        Maximum value of z over the grid.
!
!     intexp     Integral of expansion over the surface.
!     intexp2    Integral of expansion squared over the surface.
!     intarea    Area of the surface.
!
!     rhmax      Maximum radius of horizon.
!     rhmin      Minimum radius of horizon.
!
!     circ_eq    Equatorial circumference.
!     meri_p1    Length of meridian at phi=0.
!     meri_p2    Length of meridian at phi=pi/2.
!
!     c0(l)      Coefficients of LEGEN(l,0,cos(theta))
!     cc(l,m)    Coefficients of LEGEN(l,m,cos(theta))*cos(m*phi)
!     cs(l,m)    Coefficients of LEGEN(l,m,cos(theta))*sin(m*phi)
!
!     hflow*     Spectral components for "H" flow.
!     cflow*     Spectral components for "C" flow.
!     nflow*     Spectral components for "N" flow.
!
!     interror1  Different from zero if radius is negative.
!     interror2  Different from zero if outside computational domain.
!     interror3  Different from zero if inside mask
!
!     interror   True if any of the 3 errors above are non-zero.
!
!     find3      Look for 3 horizons?
!     mfind      Counter to see for which horizon we are looking.
!
!     inside_min_count        Number of elements in integral (should always
!                             be ntheta*nphi)
!
!     inside_min_neg_count    Number of elements in integral that have
!                             negative expansion.
!
!     avgx        X-position of centroid of apparent horizon
!     avgy        Y-position of centroid of apparent horizon
!     avgz        Z-position of centroid of apparent horizon


!     ***************
!     ***   END   ***
!     ***************

      end module AHFinder_dat



```

AHFinder_pow.F:
```
/*@@
  @file      AHFinder_pow.F
  @date      April 1998
  @author    Miguel Alcubierre
  @desc 
             Multidimensional minimization routines taken
             from Numerical Recipes.  The routines have some
             modifications to adapt them to the specific problem
             we are trying to solve.
  @enddesc 
@@*/

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


      module F1COM

!     Data to be shared by minimization routines.

      implicit none

      logical error

      integer NCOM

      CCTK_REAL XMIN
      CCTK_REAL, allocatable, dimension(:) :: PCOM,XICOM


!     ***************
!     ***   END   ***
!     ***************

      end module F1COM




***********************************************************************
***********************************************************************




      subroutine POWELL(CCTK_ARGUMENTS,P,XI,N,FTOL,ITER,ITMAX,FRET,found)

!     Minimization of a function FUNC on N variables (FUNC is
!     not an argument, it is a fixed function name).  Input consists
!     of an initial starting point P that is a vector of length N;
!     an initial matrix XI of dimensions NxN and whose columns contain
!     the initial set of directions (usually the N unit vectors); and
!     FTOL, the fractional tolerance in the function value such that
!     failure to decrease by more than this ammount on one iteration
!     signals doneness.  On output, P is set to the best point found,
!     XI is the then-current direction set, FRET is the returned
!     function value at P, and ITER is the number of iterations taken.
!
!     Extra output added by myself (Miguel Alcubierre) is a logical
!     variable "found" that is set to true is a minimum was indeed
!     found, and to false if it was not.

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS

      logical found

      integer i,j,N
      integer ITER,ITMAX,IBIG

      CCTK_REAL FUNC,DEL,FP,FPTT,FRET,FTOL,T,TOL1,ZEPS

      CCTK_REAL, dimension(1:N) :: P,PT,PTT,XIT
      CCTK_REAL, dimension(1:N,1:N) :: XI

      character(len=200) :: logf

      parameter (ZEPS=1.0D-10)


!     *************************
!     ***   START ROUTINE   ***
!     *************************

      FRET = FUNC(CCTK_ARGUMENTS,P,N)

!     Save initial point.

      do j=1,N
         PT(j) = P(j)
      end do

      ITER = 0

   10 ITER = ITER + 1

      if ((myproc.eq.0).and.veryver) then
         write(*,*)
         write(*,"(A20,I2)") 'POWELL ITERATION  = ',ITER
      end if

      if ((myproc.eq.0).and.logfile) then
         logf = filestr(1:nfile)//"/ahf_logfile"
         open(11,file=logf,form='formatted',status='old',
     .   position='append')
         write(11,*)
         write(11,"(A20,I2)") 'POWELL ITERATION  = ',ITER
         close(11)
      end if

      FP = FRET
      IBIG = 0

!     Initialize DEL.  It will be the biggest function decrease.

      DEL = 0.0D0

!     In each iteration, loop over all directions in the set.

      do i=1,N

!        Copy the direction.

         do j=1,N
            XIT(j) = XI(j,i)
         end do

         FPTT = FRET

!        Minimize along it.

         call LINMIN(CCTK_ARGUMENTS,P,XIT,N,FRET,FTOL)

!        And record it if it is the largest decrease so far.

         if (abs(FPTT-FRET).gt.DEL) then
            DEL  = abs(FPTT-FRET)
            IBIG = I
         end if

      end do

!     Termination criterion.

      TOL1 = 0.5D0*FTOL*(abs(FP)+abs(FRET)) + ZEPS

      if (abs(FP-FRET).le.TOL1) then
         found = .true.
         return
      else if (abs(FRET).lt.ZEPS) then
         found = .true.
         return
      end if

!     Too many iterations?

      if (ITER.ge.ITMAX) return

!     Construct the extrapolated point and the average direction.

      do j=1,N
         PTT(j) = 2.0D0*P(j) - PT(j)
         XIT(j) = P(j) - PT(j)
         PT(j)  = P(j)
      end do

!     Function value at extrapolated point.

      FPTT = FUNC(CCTK_ARGUMENTS,PTT,N)

!     First reason not to use new direction.

      if (FPTT.ge.FP) goto 10

!     Second reason not to use new direction.

      T = 2.0D0*(FP-2.0D0*FRET+FPTT)*(FP-FRET-DEL)**2
     .  - DEL*(FP-FPTT)**2

      if (T.gt.0.0D0) goto 10

!     Move to the minimum of the new direction.

      call LINMIN(CCTK_ARGUMENTS,P,XIT,N,FRET,FTOL)

!     Save new direction.

      do j=1,N
         XI(j,IBIG) = XIT(j)
      end do

!     Back for another iteration.

      goto 10


!     ***************
!     ***   END   ***
!     ***************

      end subroutine POWELL




***********************************************************************
***********************************************************************



      subroutine LINMIN(CCTK_ARGUMENTS,P,XI,N,FRET,TOL)

!     Given an N dimensional point P and an N dimensional direction XI,
!     moves and resets P to where the function FUNC takes on a
!     minimum along the direction XI from P, and replaces XI by the
!     actual vector displacement that P was moved.  Also returns as
!     FRET the value of FUNC at the returned location P.  This is
!     actually all acomplished by calling the routines MNBRAK and
!     PARABOLA.

      use F1COM

      implicit none

      DECLARE_CCTK_ARGUMENTS

      integer j,N

      CCTK_REAL XA,XB,XX,FA,FB,FX
      CCTK_REAL FRET,PARABOLA,TOL
      CCTK_REAL zero
      CCTK_REAL dx,dy,dz

      CCTK_REAL, dimension(1:N) :: P,XI

      CCTK_REAL F1DIM

      EXTERNAL  F1DIM


!     **********************************************
!     ***   ALLOCATE STORAGE FOR SHARED ARRAYS   ***
!     **********************************************

      zero = 0.0d0

      allocate(PCOM(1:N),XICOM(1:N))


!     *************************
!     ***   START ROUTINE   ***
!     *************************

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

      NCOM = N

      do j=1,N
         PCOM(j)  = P(j)
         XICOM(j) = XI(j)
      end do

!     Initial guess for brackets.

      XA = 0.0D0
      XX = 0.1D0*min(dx,dy,dz)

!     Bracket the minimum.

      call MNBRAK(CCTK_ARGUMENTS,XA,XX,XB,FA,FX,FB,F1DIM)

!     Check if function is constant.

      if ((FA.ne.FX).or.(FB.ne.FX)) then

!        Call 1D minimization.

         FRET = PARABOLA(CCTK_ARGUMENTS,XA,XX,XB,FA,FX,FB,F1DIM,TOL)

!        Construct the vector results to return.

         XI = XMIN*XI
         P  = P + XI

      end if

      
!     ******************************
!     ***   DEALLOCATE STORAGE   ***
!     ******************************

      deallocate(PCOM,XICOM)


!     ***************
!     ***   END   ***
!     ***************

      end subroutine LINMIN




***********************************************************************
***********************************************************************




      CCTK_REAL function F1DIM(CCTK_ARGUMENTS,XX)

!     Must accompany LINMIN

      use F1COM

      implicit none

      DECLARE_CCTK_ARGUMENTS

      integer j

      CCTK_REAL XX,FUNC

      CCTK_REAL, dimension(1:NCOM) :: XT


!     *************************
!     ***   START ROUTINE   ***
!     *************************

      do j=1,NCOM
         XT(j) = PCOM(j) + XX*XICOM(j)
      end do

      F1DIM = FUNC(CCTK_ARGUMENTS,XT,NCOM)


!     ***************
!     ***   END   ***
!     ***************

      end function F1DIM




***********************************************************************
***********************************************************************



      subroutine MNBRAK(CCTK_ARGUMENTS,XA,XB,XC,FA,FB,FC,FUNC)

!     Given a function FUNC, and given distinct initial points
!     XA and XB, this routine searches in the downhill direction
!     (defined by the function as evaluated at the initial points)
!     and returns new points XA, XB, XC which bracket a minimum
!     of the function.  Also returned are the function values
!     at the three points, FA, FB and FC.

      implicit none

      DECLARE_CCTK_ARGUMENTS

      CCTK_REAL XA,XB,XC
      CCTK_REAL FA,FB,FC,FU,FUNC
      CCTK_REAL DUM,Q,S,U,ULIM
      CCTK_REAL GOLD,GLIMIT,TINY

      parameter (GOLD=1.618034D0,GLIMIT=4.0D0,TINY=1.0D-20)


!     *************************
!     ***   START ROUTINE   ***
!     *************************

      FA = FUNC(CCTK_ARGUMENTS,XA)
      FB = FUNC(CCTK_ARGUMENTS,XB)

!     Switch roles of A and B so that we can go downhill
!     in the direction from A to B.

      if (FB.gt.FA) then

         DUM = XA
         XA  = XB
         XB  = DUM

         DUM = FB
         FB  = FA
         FA  = DUM

      end if

!     First guess for C.

      XC = XB + GOLD*(XB-XA)

      FC = FUNC(CCTK_ARGUMENTS,XC)

!     Check if the function is constant.

      if ((FA.eq.FB).and.(FB.eq.FC)) then
         return
      end if

!     Keep returning here until we bracket.

      do while(FB.gt.FC)

!        Compute U by parabollic extrapolation from A, B, C.
!        TINY is used to prevent any possible division by zero.

         S = (XB-XA)*(FB-FC)
         Q = (XB-XC)*(FB-FA)
         U = XB - ((XB-XC)*Q - (XB-XA)*S)
     .     / (2.0D0*SIGN(MAX(ABS(Q-S),TINY),Q-S))

!        We will not go further than this.

         ULIM = XB + GLIMIT*(XC-XB)

!        Now to test various possibilities.

         if ((XB-U)*(U-XC).gt.0.0D0) then

!           Parabolic U is between B and C, try it.

            FU = FUNC(CCTK_ARGUMENTS,U)

            if (FU.lt.FC) then

!              Got a minimum between B and C.

               XA = XB
               FA = FB
               XB = U
               FB = FU
               return

            else if (FU.gt.FB) then

!              Got a minimum between A and U.

               XC = U
               FC = FU
               return

            end if

!           Parabolic fit was no use.  Use default magnification.

            U = XC + GOLD*(XC-XB)

            FU = FUNC(CCTK_ARGUMENTS,U)

         else if ((XC-U)*(U-ULIM).gt.0.0D0) then

!           Parabolic fit is between C and its allowed limit.

            FU = FUNC(CCTK_ARGUMENTS,U)

            if (FU.lt.FC) then

               XB = XC
               XC = U
               U  = XC + GOLD*(XC-XB)
               FB = FC
               FC = FU

               FU = FUNC(CCTK_ARGUMENTS,U)

            end if

         else if ((U-ULIM)*(ULIM-XC).ge.0.0D0) then

!           Limit parabolic U to maximum allowed value.

            U = ULIM

            FU = FUNC(CCTK_ARGUMENTS,U)

         else

!           Reject parabolic U, use default magnification.

            U = XC + GOLD*(XC-XB)
            FU = FUNC(CCTK_ARGUMENTS,U)

         end if

!        Eliminate oldest point and continue.

         XA = XB
         XB = XC
         XC = U
         FA = FB
         FB = FC
         FC = FU

      end do


!     ***************
!     ***   END   ***
!     ***************

      end subroutine MNBRAK




***********************************************************************
***********************************************************************




      CCTK_REAL function PARABOLA(CCTK_ARGUMENTS,XA,XB,XC,FXA,FXB,FXC,
     .  FUNC,TOL)

!     Given a function F, and given a bracketing triplet of abscissas
!     XA, XB, XC (such that XB is between XA and XC, and F(XB) is less
!     than both F(XA) and F(XC)), this routine isolates the minimum
!     to a fractional precision of about TOL using inverse parabolic
!     interpolation. The abscissa of the minimum is returned as XMIN,
!     and the minimum function value is returned as PARABOLA, the
!     returned function value.

      use F1COM

      implicit none

      DECLARE_CCTK_ARGUMENTS

      integer ITER,ITMAX

      CCTK_REAL XA,XB,XC,FXA,FXB,FXC,FUNC,TOL
      CCTK_REAL A,B,D,P,Q,S,U,XX,XM,TOL1
      CCTK_REAL FA,FB,FU,FX,FP,ZEPS

      parameter (ITMAX=100,ZEPS=1.0D-10)


!     *************************
!     ***   START ROUTINE   ***
!     *************************

      error = .false.

!     A and B must be in ascending order, though the input
!     abscissas need not be.

      if (XC.lt.XA) then
         A = XC
         B = XA
         FA = FXC
         FB = FXA
      else
         A = XA
         B = XC
         FA = FXA
         FB = FXC
      end if

      XX = XB
      FX = FXB
      FP = FA

!     Main program loop.

      do ITER=1,ITMAX

         XM = 0.5D0*(A + B)

!        Test for done here.

         TOL1 = 0.5D0*TOL*(abs(FP)+abs(FX)) + ZEPS
         if (abs(FP-FX).le.TOL1) goto 3

!        Construct a trial parabolic fit.

         S = (XX-A)*(FX-FB)
         Q = (XX-B)*(FX-FA)
         P = (XX-B)*Q - (XX-A)*S
         Q = 2.0D0*(Q-S)

!        Check if Q is zero.  This can only happen if the
!        three points are colinear (in which case they where
!        not bracketing a minimum in the first place), or
!        if two of them are in fact the same point.

         if (Q.eq.0.0D0) then
            write(*,*) 'AHFinder: problem in PARABOLA'
            error = .true.
            return            
         end if

!        Find new point.

         D = - P/Q
         U = XX + D

!        Check if X was already the minimum.

         if (abs(U-XX).lt.ZEPS) goto 3

!        This is the one function evaluation per iteration.

         FU = FUNC(CCTK_ARGUMENTS,U)

!        And now we have to decide what to do with our function
!        evaluation.

         if (FU.le.FX) then

            if (U.ge.XX) then
               A = XX
               FA = FX
            else
               B = XX
               FB = FX
            end if

            XX = U

            FP = FX
            FX = FU

         else

            if (U.lt.XX) then
               A = U
               FA = FU
            else
               B = U
               FB = FU
            end if

         end if

      end do

      write(*,*) 'PARABOLA exceeded maximum number of iterations.'

    3 XMIN = XX
      PARABOLA = FX


!     ***************
!     ***   END   ***
!     ***************

      end function PARABOLA




***********************************************************************
***********************************************************************



      CCTK_REAL function FUNC(CCTK_ARGUMENTS,P,N)

!     This is a shell to find the surface integral of the expansion.

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS

      logical flag

      integer i,l,m,N
      integer iter

      CCTK_REAL zero,half,one
      CCTK_REAL aux

      CCTK_REAL, dimension(1:N) :: P

      character(len=200) :: logf

      save iter,logf


!     **************************
!     ***   DEFINE NUMBERS   ***
!     **************************

      zero = 0.0D0
      half = 0.5D0
      one  = 1.0D0


!     ************************
!     ***   OPEN LOGFILE   ***
!     ************************

      logf = filestr(1:nfile)//"/ahf_logfile"

      if (logfile.and.(myproc.eq.0)) then
         open(12,file=logf,form='formatted',status='old',
     .   position='append')
      end if


!     ****************************
!     ***   FIND  {c0,cc,cs}   ***
!     ****************************

      i = 0

!     Find {xc,yc,zc}.

      if (wander) then
         if (.not.refx) then
            i = i+1
            xc = P(1)
         end if
         if (.not.refy) then
            i = i+1
            yc = P(2)
         end if
         if (.not.refz) then
            i = i+1
            zc = P(3)
         end if
      end if

!     Find c0(l).

      do l=0,lmax,1+stepz
         i = i+1
         c0(l) = P(i)
      end do

!     Find {cc,cs}.

      if (nonaxi) then

!        Find cc(l,m).

         do l=1,lmax
            do m=1+stepx,l,1+stepx
               if (stepz*mod(l-m,2).eq.0) then
                  i = i+1
                  cc(l,m) = P(i)
               end if
            end do
         end do

!        Find cs(l,m).

         if (.not.refy) then
            do l=1,lmax
               do m=1,l,1+stepx
                  if (stepz*mod(l-m,2).eq.0) then
                     i = i+1
                     cs(l,m) = P(i)
                  end if
               end do
            end do
         end if

      end if


!     *********************************************
!     ***   CALCULATE EXPANSION IF WE NEED TO   ***
!     *********************************************

!     Firstcall?

      if (firstfun) then

         iter = 1

!        Find horizon function and expansion.

         call AHFinder_fun(CCTK_ARGUMENTS)
         call AHFinder_exp(CCTK_ARGUMENTS)

!        Save old values of coefficients.

         xc_old = xc
         yc_old = yc
         zc_old = zc

         c0_old = c0
         cc_old = cc
         cs_old = cs

         firstfun = .false.

!     Not first call.

      else

         iter = iter + 1

!        Check if coefficients changed from last call.
!        I check this because the minimization algorithm
!        sometimes reevaluates the function at the same
!        point twice.  Also, if only c0(0) changed, the
!        expansion will not be affected.

         flag = .false.

         if (wander) then
            if (xc.ne.xc_old) flag = .true.
            if (yc.ne.yc_old) flag = .true.
            if (zc.ne.zc_old) flag = .true.
         end if

         do l=1+stepz,lmax,1+stepz
            if (c0(l).ne.c0_old(l)) flag = .true.
         end do

         if (nonaxi) then
            do l=1,lmax
               do m=1+stepx,l,1+stepx
                  if (stepz*mod(l-m,2).eq.0) then
                     if (cc(l,m).ne.cc_old(l,m)) flag = .true.
                  end if
               end do
               if (.not.refy) then
                  do m=1,l,1+stepx
                     if (stepz*mod(l-m,2).eq.0) then
                        if (cs(l,m).ne.cs_old(l,m)) flag = .true.
                     end if
                  end do
               end if
            end do
         end if

!        If necessary, find horizon function and expansion.

         if (flag) then
            call AHFinder_fun(CCTK_ARGUMENTS)
            call AHFinder_exp(CCTK_ARGUMENTS)
         end if

!        Save old values of coefficients.

         c0_old = c0
         cc_old = cc
         cs_old = cs

      end if

      if (myproc.eq.0) then

         if (veryver) then
            write(*,*)
            write(*,"(A13,I5)") 'FUNC CALL  =',iter
         end if

         if (logfile) then
            write(12,*)
            write(12,"(A13,I5)") 'FUNC CALL  =',iter
         end if

      end if


!     **********************************
!     ***   FIND SURFACE INTEGRALS   ***
!     **********************************

      call AHFinder_int(CCTK_ARGUMENTS)

!     Messages to screen and logfile.

      if (myproc.eq.0) then

!        Find inverse of area.  Be carefull not to divide by zero!
!        Also, a value of 1.0D10 indicates an error in the integration
!        routine, and all integrals end up with the same value.
!        So dont divide by it or I will be confused later.

         if ((intarea.ne.zero).and.(intarea.ne.1.0D10)) then
            aux = one/intarea
         else
            aux = one
         end if

!        Screen.

         if (veryver) then
            write(*,*)
            write(*,"(A21,ES14.6)") ' Surface area       =',intarea
            write(*,"(A21,ES14.6)") ' Mean value of H    =',aux*intexp
            write(*,"(A21,ES14.6)") ' Mean value of H^2  =',aux*intexp2
            write(*,*) 'Number of interpolated points:     ',
     .         inside_min_count
            write(*,*) 'Number of those that are negative: ',
     .         inside_min_neg_count
         end if

!        Logfile.

         if (logfile) then
            write(12,*)
            write(12,"(A21,ES14.6)") ' Surface area       =',intarea
            write(12,"(A21,ES14.6)") ' Mean value of H    =',aux*intexp
            write(12,"(A21,ES14.6)") ' Mean value of H^2  =',aux*intexp2
            write(12,*) 'Number of interpolated points:     ',
     .         inside_min_count
            write(12,*) 'Number of those that are negative: ',
     .         inside_min_neg_count
         end if

      end if


!     ******************************
!     ***   WRITE COEFFICIENTS   ***
!     ******************************

      if (myproc.eq.0) then

!        Headers to screen.

         if (veryver) then

            write(*,*)
            write(*,"(A20)") ' Shape coefficients:'

            if (offset) then
               write(*,*)
               write(*,"(A8,ES14.6)") '   xc  =',xc
               write(*,"(A8,ES14.6)") '   yc  =',yc
               write(*,"(A8,ES14.6)") '   zc  =',zc
            end if

            write(*,*)
            write(*,*) '  l            c0_l'
            write(*,*)
            write(*,"(I4,A6,ES14.6)") 0,'      ',c0(0)

         end if

!        Headers to logfile.

         if (logfile) then

            write(12,*)
            write(12,"(A20)") ' Shape coefficients:'

            if (offset) then
               write(12,*)
               write(12,"(A8,ES14.6)") '   xc  =',xc
               write(12,"(A8,ES14.6)") '   yc  =',yc
               write(12,"(A8,ES14.6)") '   zc  =',zc
            end if

            write(12,*)
            write(12,*) '  l            c0_l'
            write(12,*)
            write(12,"(I4,A6,ES14.6)") 0,'      ',c0(0)

         end if

!        c0 coefficients.

         do l=1+stepz,lmax,1+stepz
            if (veryver) then
               write(*,"(I4,A6,ES14.6)") l,'      ',c0(l)
            end if
            if (logfile) then
               write(12,"(I4,A6,ES14.6)") l,'      ',c0(l)
            end if
         end do

!        cc and cs coefficients (only for nonaxisymmetric case).

         if (nonaxi) then

!           Reflection symmetry on y:  some coefficients are not there.

            if (.not.refy) then

               if (veryver) then
                  write(*,*)
                  write(*,*) '  l   m       cc_lm          cs_lm'
                  write(*,*)
               end if

               if (logfile) then
                  write(12,*)
                  write(12,*) '  l   m       cc_lm          cs_lm'
                  write(12,*)
               end if

               do l=1,lmax
                  do m=1,l
                     if (stepz*mod(l-m,2).eq.0) then
                        if (veryver) then
                           write(*,10) l,m,'  ',cc(l,m),' ',cs(l,m)
                        end if
                        if (logfile) then
                           write(12,10) l,m,'  ',cc(l,m),' ',cs(l,m)
                        end if
   10                   format(I4,I4,A2,ES14.6,A1,ES14.6)
                     end if
                  end do
               end do

!           No reflection symmetry on y.

            else

               if (veryver) then
                  write(*,*)
                  write(*,*) '  l   m       cc_lm'
                  write(*,*)
               end if

               if (logfile) then
                  write(12,*)
                  write(12,*) '  l   m       cc_lm'
                  write(12,*)
               end if

               do l=1,lmax
                  do m=1+stepx,l,1+stepx
                     if (stepz*mod(l-m,2).eq.0) then
                        if (veryver) then
                           write(*,20) l,m,'  ',cc(l,m)
                        end if
                        if (logfile) then
                           write(12,20) l,m,'  ',cc(l,m)
                        end if
   20                   format(I4,I4,A2,ES14.6)
                     end if
                  end do
               end do

            end if
         end if
      end if


!     *********************
!     ***   FIND FUNC   ***
!     *********************

!     The value of FUNC will be equal to the surface integral
!     of the square of the expansion or to the surface area,
!     depending on what we want to minimize.

      if (minarea) then
         FUNC = intarea
      else
         if(find_trapped_surface) then
            FUNC = intexpdel2
         else
            FUNC = intexp2
         endif
      end if


!     *************************
!     ***   CLOSE LOGFILE   ***
!     *************************

      if (logfile.and.(myproc.eq.0)) then
         close(12)
      end if


!     ***************
!     ***   END   ***
!     ***************

      end function FUNC

```

SetSym.F:
```
 /*@@
   @file    SetSym.F
   @date    March 2000
   @author  Miguel Alcubierre
   @desc
            Sets the symmetries for the AHF grid functions.
   @enddesc
 @@*/

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

 /*@@
   @routine    AHFinder_SetSym
   @date       March 2000
   @author     Miguel Alcubierre
   @desc 
               Sets the symmetries for the AHF grid functions.
   @enddesc 
   @calls     
   @calledby   
   @history 
 
   @endhistory 

@@*/

      subroutine AHFinder_SetSym(CCTK_ARGUMENTS)

      implicit none
      
      DECLARE_CCTK_ARGUMENTS 
      DECLARE_CCTK_PARAMETERS

      integer sym(3)
      integer, PARAMETER :: one = 1
      INTEGER :: ierr

c     +,+,+

      sym(1)=+1
      sym(2)=+1
      sym(3)=+1

      call SetCartSymVN(ierr,cctkGH,sym,'ahfinder::ahfgrid')
      call SetCartSymVN(ierr,cctkGH,sym,'ahfinder::ahf_exp')
      call SetCartSymVN(ierr,cctkGH,sym,'ahfinder::ahfgradn')
      call SetCartSymVN(ierr,cctkGH,sym,'ahfinder::ahfgauss')
      call SetCartSymVN(ierr,cctkGH,sym,'ahfinder::ahmask')

c     -,+,+

      sym(1)=-1
      sym(2)=+1
      sym(3)=+1

      call SetCartSymVN(ierr,cctkGH,sym,'ahfinder::ahfgradx')

c     +,-,+

      sym(1)=+1
      sym(2)=-1
      sym(3)=+1

      call SetCartSymVN(ierr,cctkGH,sym,'ahfinder::ahfgrady')

c     +,+,-

      sym(1)=+1
      sym(2)=+1
      sym(3)=-1

      call SetCartSymVN(ierr,cctkGH,sym,'ahfinder::ahfgradz')

c     End.

      end subroutine AHFinder_SetSym


 /*@@
   @file    SetSym.F
   @date    Jan 2003
   @author  Denis Pollney
   @desc
            Sets the reflection symmetry flags.
   @enddesc
 @@*/

      subroutine AHFinder_SetReflections(CCTK_ARGUMENTS)
      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS
      DECLARE_CCTK_FUNCTIONS

      CCTK_REAL, parameter :: zero = 0.0D0
      CCTK_REAL, parameter :: half = 0.5D0
      CCTK_REAL, parameter :: one  = 1.0D0

!     Find out reflection symmetries depending on
!     the values of the parameters.

      if ((CCTK_Equals(ahf_octant,"yes").eq.1).or.
     .    (CCTK_Equals(ahf_octant,"high").eq.1)) then

         refx = .true.
         refy = .true.
         refz = .true.

      else

         if (ahf_refx.ne.0) then
            refx = .true.
         else
            refx = .false.
         end if

         if (ahf_refy.ne.0) then
            refy = .true.
         else
            refy = .false.
         end if

         if (ahf_refz.ne.0) then
            refz = .true.
         else
            refz = .false.
         end if

      end if

      if (ahf_phi.eq.0) then
         refx = .true.
         refy = .true.
      end if

!     Force grid symmetries.  If the grid has some
!     symmetry (octant, quadrant, bitant), and the
!     horizon is centered on one of the symmetry
!     planes, then the grid symmetries are forced
!     on it regardless of the values of the symmetry
!     parameters.

      if (CCTK_Equals(domain,"octant").eq.1) then

         if (xc.eq.zero) refx = .true.
         if (yc.eq.zero) refy = .true.
         if (zc.eq.zero) refz = .true.

      else if (CCTK_Equals(domain,"quadrant").eq.1) then

         if (xc.eq.zero) refx = .true.
         if (yc.eq.zero) refy = .true.

      else if (CCTK_Equals(domain,"bitant").eq.1) then

         if (CCTK_Equals(bitant_plane,"xy").eq.1) then
            if (zc.eq.zero) refz = .true.
         else if (CCTK_Equals(bitant_plane,"xz").eq.1) then
            if (yc.eq.zero) refy = .true.
         else
            if (xc.eq.zero) refx = .true.
         end if

      end if

!     Check if we are using cartoon.  If we are, then the
!     corresponding symmetries are forced on the horizon.

      if (ahf_cartoon.ne.0) then
         cartoon = .true.
      else
         cartoon = .false.
      end if

      if (cartoon) then
         nonaxi = .false.
         refx = .true.
         refy = .true.
      end if

!     If desired, write values of symmetry flags to screen.

      if (veryver) then
         write(*,*)
         write(*,*) 'Symmetries used for horizon:'
         write(*,*) 'refx = ',refx
         write(*,*) 'refy = ',refy
         write(*,*) 'refz = ',refz
         write(*,*)
      end if

      end subroutine AHFinder_SetReflections

```

Output.c:
```
 /*@@
   @file      Output.c
   @date      November 10 2001
   @author    Gabrielle Allen
   @desc
              Functions to deal with making AHFinder an IO method
   @enddesc
   @version   $Id$
 @@*/

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

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

CCTK_FILEVERSION(CactusEinstein_AHFinder_Output_c)

static int ahf_ncall=0;

int AHFinder_TimeForOutput (const cGH *GH, int vindex);

 /*@@
   @routine    AHFinder_TimeForOutput
   @date       June 31 1999
   @author     Gabrielle Allen
   @desc
               Decides if it is time to output a variable using info output
   @enddesc
   @calls      CheckSteerableParameters

   @var        GH
   @vdesc      Pointer to CCTK GH
   @vtype      const cGH *
   @vio        in
   @endvar
   @var        vindex
   @vdesc      index of variable to check for output
   @vtype      int
   @vio        in
   @endvar

   @returntype int
   @returndesc
               true/false (1 or 0) if analysis should be called
   @endreturndesc
@@*/
int AHFinder_TimeForOutput (const cGH *GH, int vindex)
{
  DECLARE_CCTK_PARAMETERS

  int retval=1;
  int ahfafter;

  if (vindex==CCTK_VarIndex("ahfinder::triggervar"))
  {

    if (ahf_findaftertime <= 0) 
    {
      ahfafter = ahf_findafter;
      if (GH->cctk_iteration < ahfafter) {retval=0;}
    }
    else
    {
      if (GH->cctk_time < ahf_findaftertime) {retval=0;}
      if (ahf_ncall == 0) {ahfafter = GH->cctk_iteration;}
    }
  
    if ( ((GH->cctk_iteration-ahfafter) % ahf_findevery) ) 
    {
      retval = 0;
    }

    if (retval==1) {ahf_ncall = 0;}

  }
  else
  {
    retval = 0;
  }
      
  return retval;
}






```

AHFinder_find3.F:
```
/*@@
  @file      AHFinder_find3.F
  @date      March 1999
  @author    Lars Nerger
  @desc 
             Muliplicate gridfunctions for final grid function
  @enddesc 
@@*/

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

!     To output single gridfunctions when searching for 3 horizons
!     the gridfunctions are here multiplied.  The result of this is
!     that the functions ahfgrid3 and ahf_exp3 will have zeroes at
!     the location of all 3 horizons.

      subroutine AHFinder_find3(CCTK_ARGUMENTS,mtype)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS

      integer mtype

      CCTK_REAL one

!     Description of variables
!
!     mtype     Type of surface: see AHFinder.F


!     **********************
!     ***   DEFINE one   ***
!     **********************

      one  = 1.0D0

!     *************************
!     ***   START ROUTINE   ***
!     *************************

!     For first outer horizon initialize {ahfgrid3,ahf_exp3}.

      if ( mfind .eq. 1) then
         if ( mtype .eq. 1 ) then

            ahfgrid3 = ahfgrid
            ahf_exp3 = ahf_exp

         else

!           If we did not find an outer horizon, make {ahfgrid3,ahf_exp3}
!           equal to one.

            ahfgrid3 = one
            ahf_exp3 = one

         end if

!     For second and third horizons, if we found an outer
!     horizon multiply the old values of {ahfgrid3,ahf_exp3}
!     with the new {ahfgrid3,ahf_exp3}.

      else if (mtype.eq.1) then

         ahfgrid3 = ahfgrid*ahfgrid3
         ahf_exp3 = ahf_exp*ahf_exp3

      end if


!     ***************
!     ***   END   ***
!     ***************

      end subroutine AHFinder_find3


```

AHFinder_initguess.F:
```
/*@@
  @file      AHFinder_initguess.F
  @date      July 1999
  @author    Miguel Alcubierre
  @desc 
             Find initial guess for minimization algorithm
  @enddesc 
@@*/

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

      subroutine AHFinder_initguess(CCTK_ARGUMENTS,rmx)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS

      integer i,j
      integer nn0,nn2,min_i,min_j

      CCTK_REAL zero,one,cc0,cc2,rmx,aux,min_aa
      CCTK_REAL, allocatable, dimension(:,:) :: aa,a0,a2
      
!     Description of variables
!
!     i,j       Counters.     
!
!     aa        Area array for initial guess.
!     a0        c0(0) array for initial guess.
!     a2        c0(2) array for initial guess.
!
!     rmx       Radius of largest sphere that fits in the grid.
!
!     nn0       Number of subdivisions of c0(0) for initial guess.
!     nn2       Number of subdivisions of c0(2) for initial guess.


!     **********************
!     ***   INITIALIZE   ***
!     **********************

!     define numbers

      zero = 0.0D0
      one  = 1.0D0

      aux = rmx

!     Initialize arrays.

      c0 = zero
      cc = zero
      cs = zero

      cc0 = zero
      cc2 = zero

!     Get {nn0,nn2}.

      nn0 = ahf_nn0
      nn2 = ahf_nn0

      if (cartoon) nn2 = 0

!     Allocate storage.

      allocate(aa(0:nn0,0:nn2))
      allocate(a0(0:nn0,0:nn2))
      allocate(a2(0:nn0,0:nn2))

      aa = zero; a0 = zero; a2 = zero


!     ****************************
!     ***  FIND INITIAL GUESS  ***
!     ****************************

!     IMPORTANT:  In order to choose a good initial guess,
!     I map a section of the space {c0(0),c0(2)} looking
!     for a local minimum.  This is VERY expensive, so the
!     parameter space is not very well convered.

      if (veryver.and.(myproc.eq.0)) then
         write(*,*)
         write(*,*) 'Choosing initial guess ...'
      end if

!     lmax >= 2 and good guess.

      if ((lmax.ge.2).and.(.not.sloppy)) then

         do j=0,nn2

            c0(2) = (0.5D0*dble(j)/dble(nn2) - 0.25D0)*aux

            call AHFinder_fun(CCTK_ARGUMENTS)
            call AHFinder_exp(CCTK_ARGUMENTS)

            do i=0,nn0

               c0(0) = 4.0D0*dx + (aux-4.0D0*dx)*dble(i)/dble(nn0)

               a0(i,j) = c0(0)
               a2(i,j) = c0(2)

               call AHFinder_int(CCTK_ARGUMENTS)

               if (minarea) then
                  aa(i,j) = intarea
               else
                  aa(i,j) = intexp2
               end if

               if (guessverbose) then
                  write(*,*)
                  write(*,"(A12,2ES14.6)") ' a0 and a2: ',a0(i,0),a2(i,0)
                  write(*,"(A6,ES14.6)")   ' H  : ',intexp
                  write(*,"(A6,ES14.6)")   ' H^2: ',intexp2
               end if

            end do
         end do

         if ((.not.inner).or.(minarea)) then

            min_i = 1
            min_j = 1
            min_aa = 1.0d15

            do i=1,nn0-1
               do j=1,nn2-1
                  if ((aa(i,j).gt.zero).and.
     .                (aa(i,j).lt.aa(i+1,j)).and.
     .                (aa(i,j).lt.aa(i-1,j)).and.
     .                (aa(i,j).lt.aa(i,j+1)).and.
     .                (aa(i,j).lt.aa(i,j-1))) then
                     cc0 = a0(i,j)
                     cc2 = a2(i,j)
                  end if
                  if (aa(i,j) .le. min_aa) then
                     min_i = i
                     min_j = j
                     min_aa = aa(i,j)
                  end if
               end do
            end do

         else

            min_i = nn0-1
            min_j = 1
            min_aa = 1.0d15

            do i=nn0-1,1,-1
               do j=1,nn2-1
                  if ((aa(i,j).gt.zero).and.
     .                (aa(i,j).lt.aa(i+1,j)).and.
     .                (aa(i,j).lt.aa(i-1,j)).and.
     .                (aa(i,j).lt.aa(i,j+1)).and.
     .                (aa(i,j).lt.aa(i,j-1))) then
                     cc0 = a0(i,j)
                     cc2 = a2(i,j)
                  end if
                  if (aa(i,j).le.min_aa) then
                     min_i = i
                     min_j = j
                     min_aa = aa(i,j)
                  end if
               end do
            end do

         end if

         if (guess_absmin) then
            cc0 = a0(min_i,min_j)
            cc2 = a2(min_i,min_j)
         endif

!        Set up initial guess.

         c0(0) = cc0
         c0(2) = cc2

!     lmax < 2 or sloppy guess.

      else

         call AHFinder_fun(CCTK_ARGUMENTS)
         call AHFinder_exp(CCTK_ARGUMENTS)

         do i=0,nn0

            c0(0) = 4.0D0*dx + (aux-4.0D0*dx)*dble(i)/dble(nn0)

            a0(i,0) = c0(0)

            call AHFinder_int(CCTK_ARGUMENTS)

            if (minarea) then
               aa(i,0) = intarea
            else
               aa(i,0) = intexp2
            end if

            if (guessverbose) then
               write(*,*)
               write(*,"(A6,ES14.6)") ' a0 : ',a0(i,0)
               write(*,"(A6,ES14.6)") ' H  : ',intexp
               write(*,"(A6,ES14.6)") ' H^2: ',intexp2
            end if

         end do

         if ((.not.inner).or.(minarea)) then

            do i=1,nn0-1
               if ((aa(i,0).gt.zero).and.
     .             (aa(i,0).lt.0.9D0*aa(i+1,0)).and.
     .             (aa(i,0).lt.0.9D0*aa(i-1,0))) then
                  cc0 = a0(i,0)
               end if
            end do

         else

            do i=nn0-1,1,-1
               if ((aa(i,0).gt.zero).and.
     .             (aa(i,0).lt.0.9D0*aa(i+1,0)).and.
     .             (aa(i,0).lt.0.9D0*aa(i-1,0))) then
                  cc0 = a0(i,0)
               end if
            end do

         end if

!        Set up initial guess.

         c0(0) = cc0

      end if

!     If no local minimum was found, start with
!     a large sphere anyway.

      if (c0(0).eq.zero) then
         c0    = zero
         c0(0) = rmx
      end if


!     ***************
!     ***   END   ***
!     ***************

!     Print message.

      if (veryver.and.(myproc.eq.0)) then
         write(*,*)
         write(*,*) 'Initial guess found'
         if (lmax.lt.2) then
            write(*,"(A8,ES14.6)") ' c0(0): ',c0(0)
         else
            write(*,"(A14,2ES14.6)") ' c0(0),c0(2): ',c0(0),c0(2)
         end if
      end if

!     Deallocate storage.

      deallocate(aa,a0,a2)


      end subroutine AHFinder_initguess


```

Startup.c:
```
 /*@@
   @file      Startup.c
   @date      Sat 10th November 2001
   @author    Gabrielle Allen
   @desc
              Startup routines for AHFinder.
   @enddesc
   @version   $Id$
 @@*/

#include "cctk.h"

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

CCTK_FILEVERSION(CactusEinstein_AHFinder_Startup_c)

int AHFinder_TimeForOutput (const cGH *GH, int vindex);

/********************************************************************
 ********************    External Routines   ************************
 ********************************************************************/
int AHFinder_Startup (void);

 /*@@
   @routine   AHfinder_Startup
   @date      Sat 10th November 2001
   @author    Gabrielle Allen
   @desc
              The startup registration routine for AHFinder.
              Registers AHFinder as an IO Method and provide the
              only necessary method TimeForOutput
   @enddesc
   @calls     CCTK_RegisterGHExtensionSetupGH
@@*/
int AHFinder_Startup (void)
{
  int handle;

  handle = CCTK_RegisterIOMethod ("AHFinder");
  CCTK_RegisterIOMethodTimeToOutput (handle, AHFinder_TimeForOutput);

  return 0;
}





```


combined_doc_context: ## README (README):
```
Cactus Code Thorn AHFinder
Author(s)    : Miguel Alcubierre
Maintainer(s): Cactus team
Licence      : LGPL
--------------------------------------------------------------------------

1. Purpose

This thorn looks for apparent horizons (AH) in 3D.  An AH is defined
as a surface where the expansion of outgoing null geodesics is zero.

NOTE:  THIS FILE IS SOMEWHAT OUT OF DATE.  I WILL UPDATE IT WHEN
I HAVE MORE TIME.  PLEASE LOOK AT THE FILE `MinimumAHF_param.h'
FOR A MORE UP TO DATA DESCRIPTION OF THE PARAMETERS.


BRIEF DESCRIPTION
-----------------

This thorn looks for apparent horizons (AH) in 3D using two
different algorithms.  In the default mode, it uses a minimization
algorithm.  It can also use a flow algorithm if one sets the
parameter "ahf_flow" equal to "yes":

ahf_flow = "yes"

The minimization algorithm is VERY slow if one has a lot of terms
in the spherical harmonics expansion (see below), but it is quite
fast for a small number of terms.

The thorn is activated by adding the following line to the parameter
file:

ahfinder::ahf_active      = "yes"

Also, one needs to tell the routine how often we want to
look for AH by using the parameter `mahf_findevery' (its
default value is 1).

The routine defines the grid function `mahfgrid' as:

ahfgrid  =  r  -  f(theta,phi)

So that the surface being considered corresponds to the zero level of
`mahfgrid'.  The function f(theta,phi) is expanded in spherical
harmonics Y(l,m).  Notice, however, that I DO NOT use the standard
normalization factor:

sqrt( (2l + 1) (l - m)! / 4 pi (l + m)! )

I use instead:

sqrt( 2l + 1 )                           m = 0

sqrt( 2 (2l + 1) (l - m)! / (l + m)! )   m != 0

Notice first that I leave out the 4*pi.  This is because I want Y(0,0)
to be the real radius of a sphere.  Also, for M non-zero I have an
extra sqrt(2).  I need this because I use a real basis with sines and
cosines instead of complex exponentials.


The minimization algorithm has three main modes of operation:

* Default mode: In the default mode, the routine tries to
find a minimum of the integral of the square of the expansion.
At an AH, this integral should be zero, and for any other
surface it will be positive.  One must remember that the
routine can easily end up in a local minimum that is not
a horizon.  To try to prevent this, the routine first
looks through a subset of the parameter space to try
to find a good guess for the global minimum.  This, of
course can fail.

* Area minimization mode:  This mode is activated by
setting the parameter:

mahf_minarea = "yes"

In this mode, the routine looks for a local minimum of the surface
area.  For time-symmetric data (and only then), such a minimum will
correspond to an AH.

* Trapped surface finding mode:  This mode is activated by
setting the parameter:

mahf_trapped_surface = "yes"

In this mode, the routine looks for a local minimum of the integral of
the square of the quantity (expansion + trapped_surface_delta).  If
trapped_surface_delta is positive, then the routine will try to find a
surface whose expansion is -(trapped_surface_delta) everywhere on the
surface.  One can monitor the number of interpolated points that have
a negative expansion by setting veryverbose = "yes", which indicates
whether or not a trapped surface has truly been found.

OUTPUT
------

The routine controls its own output.  It produces output of 2 grid
functions (mahfgrid, mahf_exp) on its own (so please don't add them to
the Cactus output).  The reason for this is that the finder might be
called at times that have nothing to do with when Cactus wants to do
output.

The grid function `mahfgrid' was described above.  The grid function
`mahf_exp' is the expansion of outgoing photons on the level sets of
`mahfgrid'.

The finder also produces a series of data files:

1) "mahf_coeff.alm"

This file contains the coefficients of the spherical
harmonics expansion of the surface found.  Notice
that the finder almost always finds a surface, but this
might not be a horizon, so be careful.

The format in which these coefficients are saved is the following:

* Lines beginning with # are comments. These include the time
  at which the finder was called, and a line stating if the
  surface found is a horizon or not.

* Empty lines indicate different calls to the finder (used when
  the finder is called many times during an evolution).

* The coefficients are saved using a loop of the form:

  do l=1,lmax
     do m=-l,l
        write(*,*) a(l,m),l,m
     end do
  end do

  Notice that because our functions are real, I use an expansion
  in sines and cosines and I really only consider positive values
  of m. On output my convention is that coefficients with positive
  m represent the terms:

  P_(l,m) cos(m theta)

  and coefficients with negative m represent the terms:

  P_(l,m) sin(m theta)

2) "mahf.gauss"

  This file contains a map of the gaussian curvature on the surface.
  The format of this file might still change in the near future.
  I need to talk to Werner about this.

* Lines beginning with # are comments.

* The data is written is a loop:
 
  do i=0,ntheta-1
     do j=0,nphi-1
        write gaussian(i,j)
     end do
  end do
 
  theta and phi are subdivided uniformly
  (according to grid type) in the intervals:
 
  octant:    theta=[0,pi/2]  phi=[0,pi/2]
  quadrant:  theta=[0,pi]    phi=[0,pi/2]
  full:      theta=[0,pi]    phi=[0,2 pi]

3) "mahf_area.tl"

   Area of the surface for each time the finder was called.
   Again, remember that the surface might not be a horizon.

4) "mahf_mass.tl"

   Mass of the surface for each time the finder was called.
   This is defined as:

   M = sqrt(A/(16 pi))

   Again, remember that the surface might not be a horizon.

5) "mahf_circ_eq.tl"

   Equatorial circumference of the surface.
   Again, remember that the surface might not be a horizon.

6) "mahf_meri_p1.tl"

   Length of meridian of surface for phi=0.
   Again, remember that the surface might not be a horizon.

7) "mahf_meri_p2.tl"

   Length of meridian of surface surface for phi=pi/2.
   Again, remember that the surface might not be a horizon.

8) "mahf_logfile"

   Log file for the last time the horizon was called.  The
   reason why only the last call is here is that this file
   is very long.


PARAMETERS
----------

Other parameters for the thorn are (see also file MinimumAHF_param.h):


STRINGS:

mahf_logfile     = [yes,no]      Write a log file.  If yes, the
                                 thorn produces the file "mahf_logfile".
                                 (default = "no")

mahf_verbose     = [yes,no]      Write messages to screen.
                                 (default = "yes")

mahf_veryverbose = [yes,no]      Write lots of messages to the screen,
                                 essentially the whole log file.
                                 (default = "no")

mahf_guessverbose = [yes,no]     Write a little info for each trial point
                                 calculated in the guess process.
                                 (default = "no")

mahf_2Doutput    = [yes,no]      2D output of grid functions?
                                 (default = "no")

mahf_3Doutput    = [yes,no]      3D output of grid functions?
                                 (default = "no")

mahf_mask        = [yes,no]      Use mask for definite horizons?
                                 (default = "no")

mahf_weakmask    = [yes,no]      Use mask for possible horizons?
                                 (default = "no")

mahf_phi         = [yes,no]      Expand in phi.  It is useful to switch
                                 this off if one knows in advance that
                                 the horizon is really axisymmetric.
                                 (default = "yes")

mahf_offset      = [yes,no]      Is the center offset from origin?
                                 (default = "no")

mahf_wander      = [yes,no]      Do we allow the center to wander?
                                 (default = "no")

mahf_refx        = [yes,no]      Do we have reflection symmetry x -> -x?
                                 (default = "no")

mahf_refy        = [yes,no]      Do we have reflection symmetry y -> -y?
                                 (default = "no")

mahf_refz        = [yes,no]      Do we have reflection symmetry z -> -z?
                                 (default = "no")

mahf_octant      = [yes,no,high] Does the surface have octant symmetry?
                                 The "high" option forces also reflection
                                 symmetry across the x-y diagonal.
                                 (default = "no")

mahf_areamap     = [yes,no]      Construct an area map?.
                                 (default = "no")

mahf_sloppyguess = [yes,no]      This considers only spheres for the
                                 initial guess. It is much faster.
                                 (default = "no")

mahf_guessold    = [yes,no]      Use horizon found in previous call as
                                 initial guess?  Only relevant for
                                 evolutions.
                                 (default = "no")

mahf_inner       = [yes,no]      Tries to look for inner horizon instead.
                                 (default = "no")

mahf_guess_absmin = [yes,no]     Use the absolute minimum of the surface
                                 integral of the square of the expansion
                                 as the place to start the minimization
                                 process.  This is useful if you have
                                 a very dynamical spacetime, with possibly
                                 many local minima and you don't have any
                                 idea where (or even if) you have an AH.
                                 (default = "no")

mahf_manual_guess = [yes,no]     Use a manually specified guess, via. the
                                 parameters mahf_l0_guess, mahf_l2_guess,
                                 etc. (works only in octant mode right now)
                                 (default = "no")

INTEGERS:

mahf_findafter                   After how many timesteps start looking
                                 for horizons (default 0).

mahf_findevery                   How often to look for horizons (iterations).
                                 (default 1)

mahf_maxiter                     Maximum number of iterations of
                                 Powell's minimization algorithm.
                                 (default 10)

mahf_flowiter                    Maximum number of iterations for flow
                                 (default 200)

mahf_lmax (<20)                  Number of terms in theta expansion
                                 (default 2)

mahf_ntheta                      Number of subdivisions in theta for
                                 surface integrals (default 200).

mahf_nphi                        Number of subdivisions in phi for
                                 surface integrals (default 200).

mahf_nn0                         Number of subdivisions of c0(0) for
                                 initial guess (default 10)

mahf_nn2                         Number of subdivisions of c0(2) for
                                 initial guess (default 10)


REALS:

mahf_findaftertime               After what time start looking for horizons.
                                 A non-zero value of this parameter overrides
                                 the paramter `mahf_findafter' above.
                                 (default 0.0)

mahf_r0                          Radius of initial sphere (0 forces largest
                                 possible sphere)
                                 (default 0.0)

mahf_xc                          x coordinate of center of expansion
                                 (default 0.0)

mahf_yc                          y coordinate of center of expansion
                                 (default 0.0)

mahf_zc                          z coordinate of center of expansion
                                 (default 0.0)

mahf_tol                         Fractional tolerance for minimization
                                 algorithm.  If we decrease by less than
                                 this in one iteration we are done.
                                 (default = 0.1)

trapped_surface_delta            In 'mahf_trapped_surface' mode, this 
                                 determines the expansion of the surface
                                 that one is looking for. Notice that a
                                 positive value of 'mahf_trapped_surface'
                                 will cause the finder to look for a 
                                 surface with expansion equal to MINUS
                                 this value everywhere.
                                 (default = 0.0)

mahf_flowa                       Alpha parameter for flow (default 0.01).

mahf_flowb                       Beta parameter for flow (default 0.01).

mahf_flowh                       Weight of H flow (default 0.0).

mahf_flowc                       Weight of C flow (default 1.0).

mahf_flown                       Weight of N flow (default 0.0).

mahf_flowtol                     Tolerance for flow (default 0.0001).

mahf_maskshrink                  Shrink factor for mask (default 0.9).


IMPORTANT:  Notice that the symmetry parameters refer to the surface
itself, and not to the grid.


2. Dependencies of the thorn

This thorn additionally requires thorns:  GenericAHF, util.
For testing purposes, one also needs:     analyticBH, exact.


3. Thorn distribution

This thorn is available to everyone.


4. Additional information


```

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

```tex
=== documentation.tex ===
% *======================================================================*
%  Cactus Thorn template for ThornGuide documentation
%  Author: Ian Kelley
%  Date: Sun Jun 02, 2002
%  $Header$                                                             
%
%  Thorn documentation in the latex file doc/documentation.tex 
%  will be included in ThornGuides built with the Cactus make system.
%  The scripts employed by the make system automatically include 
%  pages about variables, parameters and scheduling parsed from the 
%  relevent thorn CCL files.
%  
%  This template contains guidelines which help to assure that your     
%  documentation will be correctly added to ThornGuides. More 
%  information is available in the Cactus UsersGuide.
%                                                    
%  Guidelines:
%   - Do not change anything before the line
%       % BEGIN CACTUS THORNGUIDE",
%     except for filling in the title, author, date etc. fields.
%   - You can define your own macros are OK, but they must appear after
%     the BEGIN CACTUS THORNGUIDE line, and do not redefine standard 
%     latex commands.
%   - To avoid name clashes with other thorns, 'labels', 'citations', 
%     'references', and 'image' names should conform to the following 
%     convention:          
%       ARRANGEMENT_THORN_LABEL
%     For example, an image wave.eps in the arrangement CactusWave and 
%     thorn WaveToyC should be renamed to CactusWave_WaveToyC_wave.eps
%   - Graphics should only be included using the graphix package. 
%     More specifically, with the "includegraphics" command. Do
%     not specify any graphic file extensions in your .tex file. This 
%     will allow us (later) to create a PDF version of the ThornGuide
%     via pdflatex. |
%   - References should be included with the latex "bibitem" command.  
%   - For the benefit of our Perl scripts, and for future extensions, 
%     please use simple latex.     
%
% *======================================================================* 
% 
% Example of including a graphic image:
%    \begin{figure}[ht]
%       \begin{center}
%          \includegraphics[width=6cm]{MyArrangement_MyThorn_MyFigure}
%       \end{center}
%       \caption{Illustration of this and that}
%       \label{MyArrangement_MyThorn_MyLabel}
%    \end{figure}
%
% Example of using a label:
%   \label{MyArrangement_MyThorn_MyLabel}
%
% Example of a citation:
%    \cite{MyArrangement_MyThorn_Author99}
%
% Example of including a reference
%   \bibitem{MyArrangement_MyThorn_Author99}
%   {J. Author, {\em The Title of the Book, Journal, or periodical}, 1 (1999), 
%   1--16. {\tt http://www.nowhere.com/}}
%
% *======================================================================* 

% If you are using CVS use this line to give version information
% $Header$

\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}

% The author of the documentation
\author{Miguel Alcubierre/Latex version by Peter Diener} 

% The title of the document (not necessarily the name of the Thorn)
\title{AHFinder}

% the date your document was last changed, if your document is in CVS, 
% please us:
%    \date{$ $Date$ $}
\date{$ $Date$ $}

\maketitle

% Do not delete next line
% START CACTUS THORNGUIDE

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

% Add an abstract for this thorn's documentation
\begin{abstract}
Finding Apparent Horizons in a numerical spacetime
\end{abstract}

% The following sections are suggestive only.
% Remove them or add your own.

\section{Purpose}

Thorn {\tt AHFinder} finds Apparent Horizons (AHs) in numerical
spacetimes. It calulates various quantities like horizon area and
its corresponding mass.

\section{Using AHFinder}

Thorn AHFinder can be used either with a minimization or a flow algorithm.
\subsection{Parameters}
\subsubsection*{General parameters}
\begin{itemize}
\item {\tt ahfinder::ahf\_active} (steerable) \\
        To activate the thorn set ahf\_active = "yes". This parameter is set
        by default to "no". \\
\item {\tt ahfinder::ahf\_flow} (steerable) \\
        By default the minimization algorithm is used. To switch to the
        flow algorithm one has to set ahf\_flow = "yes"
\end{itemize}
\subsubsection*{Parameters used in evolutions}
\begin{itemize}
\item {\tt ahfinder::ahf\_findevery} (steerable) \\
        Specifies how often the finder is called. The default is to find
        horizons at every iteration.
\item {\tt ahfinder::ahf\_findafter} (steerable) \\
        The number of iterations after which the thorn is called the
        first time can be specified by this parameter. Here the default is 0,
        calling the thorn also on the initial time slice.
\item {\tt ahfinder::ahf\_findaftertime} \\
        Instead of specifying the number of iterations, one can specify
        after how much coordinate time the thorn is called the first time.
        When different from zero, this parameter overrides the value of
        ahf\_findafter. Default here is also 0.
\end{itemize}
\subsubsection*{Parameters specifying the expansion of the surface in sperical
                harmonics.}
\begin{itemize}
\item {\tt ahfinder::ahf\_lmax} \\
        The maximal number of terms in the expansion in $\theta$. The default
        value is 8. The maximal value is 19.
\item {\tt ahfinder::ahf\_phi} (steerable) \\
        If axisymmetry is expected the surface does not need to be
        expanded in phi. This is the default. To look for non-axisymmetric
        surface use ahf\_phi = "yes".
\item {\tt ahfinder::ahf\_[xyz]c} (steerable) \\
        Sets the x-, y-, and z-coordinates of the center of the expansion.
        The default is the origin (ahf\_xc = 0, ahf\_yc = 0, ahf\_zc = 0).
        The center of the expansion should be set inside the expected
        apparent horizon, otherwise the algorithm will fail.
\item {\tt ahfinder::ahf\_wander} \\
        The center of the expansion can also be allowed to move. To do this
        use ahf\_wander = "yes". However, this only works with the
        minimization algorithm. The default is for the center not to move.
\item {\tt ahfinder::ahf\_r0} (steerable) \\
        Sets the radius of the initial sphere. The default is 0.0, forcing
        the largest sphere possible in the grid.
\end{itemize}
\subsubsection*{Looking for three horizons}
The finder can also be used to look for three horizons each time.
This is done by just running the algorithm three consecutive times
with different initial guesses, and is useful for simulations of
black hole collisions.
\begin{itemize}
\item {\tt ahfinder::ahf\_find3} \\
        Set ahf\_find3 = "yes" to search for three horizons. The default is
        to look for only one horizon.
\item {\tt ahfinder::ahf\_[xyz]\_[012]} (steerable) \\
       Sets the x-, y-, and z-coordinates of the center of the expansion for
       horizon 0, 1 and 2. The default in each case is the origin.
\item {\tt ahfinder::ahf\_r0\_[0-2]} (steerable) \\
        Sets the radius of the initial spheres for horizon 0, 1 and 2.
        The default in all cases is 0.0, forcing the largest sphere possible
        in the grid.
\end{itemize}
\subsubsection*{Further parameters for the initial guess}
The initial guess can be furthermore controlled by some parameters
which are set to "no" by default.
\begin{itemize}
\item {\tt ahfinder::ahf\_guessold} (steerable) \\
        To use on old horizon as initial guess set ahf\_guessold = "yes".
        However, if during the evolution the apparent horizon jumps
        discontinuously it might be lost by using this option.
\item {\tt ahfinder::ahf\_nn0, ahfinder::ahf\_nn2} \\
        If no old horizon is used the inital guess can be specified
        further for the minimization algorithm. This algorithm is
        sensitive to the initial guess, so this is important. The initial
        guess is set up by an expansion in spherical harmonics in the
        first two coefficients (l=0,l=2). The default for both these
        parameters are 10, in which case the algorithm tests 100 different
        combinations to find the best initial guess.
\item {\tt ahfinder::ahf\_sloppyguess} \\
        It is also possible to use only a sphere as initial guess. This
        is much faster and is done by using ahf\_sloppyguess = "yes". In this
        case a number of spheres (specified by ahf\_nn0) with different radii
        are tested for the initial guess.
\item {\tt ahfinder::ahf\_inner} \\
        If one wants to look for an inner horizon instead of an outer
        one, use ahfinder::ahf\_inner = "yes". This only works with the
        minimization algorithm.
\end{itemize}
\subsubsection*{Parameters for surface intergrals}
\begin{itemize}
\item {\tt ahfinder::ahf\_ntheta} (steerable) \\
        The number of subdivisions in $\theta$. Default is 200.
\item {\tt ahfinder::ahf\_nphi} (steerable) \\
        The number of subdivisions in $\phi$. Default is 200.
\end{itemize}
\subsubsection*{Parameters indicating symmetries}
\begin{itemize}
\item {\tt ahfinder::ahf\_ref[xyz]} (steerable) \\
        Specifies the existence of reflection symmetry on the yz-plane,
        xz-plane and xy-plane respectively. By default all are set to "no".
\item {\tt ahfinder::ahf\_octant} (steerable) \\
        Octant symmetry is specified by using ahf\_octant = "yes". This is set
        to "no" by default. Possible parmeter settings are "yes" for reflection
        symmetries on all three coordinate planes and "high" for an additional
        rotational symmetry of $\pi/2$ around the z axis.
\item {\tt ahfinder::ahf\_cartoon} (steerable) \\
        A further symmetry can (must) be specified when running with the
        "axisymmetric" mode given by the Cartoon method by using
        ahf\_cartoon = "yes". This is set to "no" by default.
\end{itemize}
\subsubsection*{Parameters for minimization algorithm}
\begin{itemize}
\item {\tt ahfinder::ahf\_tol} \\
        Sets the tolerance for the minimization algorithm. The default
        value is 0.1.
\item {\tt ahfinder::ahf\_maxiter} \\
        Sets the maximum number if iterations for each step of the POWELL
        algorithm. The default value is 10.
\item {\tt ahfinder::ahf\_minarea} \\
        Usually the square of the expansion is minimized. To switch to
        minimization of the area one can use ahf\_minarea = "yes"
        (default is "no"). Notice that only for time symmetric data the
        surface found by area minimization will correspond to an apparent
        horizon.
\end{itemize}
\subsubsection*{Parameters for the flow algorithm}
\begin{itemize}
\item {\tt ahfinder::ahf\_flow} (steerable) \\
        The fow algotithm is used by setting ahf\_flow = "yes". The default
        is "no"
\item {\tt ahfinder::ahf\_flowiter} (steerable) \\
        Sets the maximum number of iterations for the flow algorithm. The
        default value is 200.
\item {\tt ahfinder::ahf\_flowtol} \\
        Sets the tolerance for the flow. The default value is 0.0001.
\item {\tt ahfinder::ahf\_flowa} \\
        Sets the $\alpha$ parameter for the flow. The default value is 0.01.
\item {\tt ahfinder::ahf\_flowb} \\
        Sets the $\beta$ parameter for the flow. The default value is 0.5.
\item {\tt ahfinder::ahf\_flowh} \\
        Sets the weight of $H$ flow. The default value is 0.0.
\item {\tt ahfinder::ahf\_flowc} \\
        Sets the weight of $C$ flow. The default value is 1.0.
\item {\tt ahfinder::ahf\_flown} \\
        Sets the weight of $N$ flow (not yet implemented). The default
        value is 0.0.
\end{itemize}
The character of the different flows and the $\alpha$ and $\beta$
parameters are described in Carsten Gundlach's paper on his
pseudo-spectral apparent horizon finder (gr-qc/9707050).
\subsubsection*{Parameters for output}
\begin{itemize}
\item {\tt ahfinder::ahf\_logfile} \\
        By default no logfile for AHFinder is written. To obtain a log
        file one must set ahf\_logfile = "yes".
\item {\tt ahfinder::ahf\_verbose} \\
        if ahf\_verbose = "yes" messages are printed to screen at the
        beginning and the end of the algorithm. This is the default.
\item {\tt ahfinder::ahf\_veryverbose} \\
        if ahf\_veryverbose = "yes" messages are also printed to screen
        during the iteration process. The default is "no".
\item {\tt ahfinder::ahf\_2Doutput} (steerable) \\
        To get 2D output of grid functions use ahf\_2Doutput = "yes" (default
        is "no"). The output is controlled be the thorn itself, not by cactus
        standard output.
\item {\tt ahfinder::ahf\_3Doutput} (steerable) \\
        In future versions to get 3D output of grid functions use
        ahf\_3Doutput = "yes" (default is "no").
\item {\tt ahfinder::ahf\_areamap} \\
        To get an area map use ahf\_areamap = "yes" (default is "no").
        This is useful for looking at the behaviour of the area for
        surfaces close to the horizon.
\end{itemize}
\subsubsection*{Parameters for mask}
\begin{itemize}
\item {\tt ahfinder::ahf\_mask} (steerable) \\
        The mask is 0 inside the horizon and 1 outside, and is used in
        black-hole excision techniques. By default the mask is off. It
        can be enabled by setting ahf\_mask = "strong", which sets the mask
        only if the finder is sure that a horizon was found, or by setting
        ahf\_mask = "weak", which makes the finder set the mask also if a
        horizon is probably there but either the resolution or lmax are to
        low to really resolve it.
\item {\tt ahfinder::ahf\_masktype} (steerable) \\
        The mask can be of two types. Either ahf\_masktype = "simple",
        which masks a cube contained inside the horizons, or ahf\_masktype
        = "lego", which masks a lego-sphere.
\item {\tt ahfinder::ahf\_maskshrink} (steerable) \\
        Sets a buffer zone between the region inside the horizon and the
        region where the mask is 0, by limiting the mask to a region smaller
        than ahf\_maskshrink times the horizon radius. The default value
        is 0.8.
\item {\tt ahfinder::ahf\_maskbuffer} (steerable) \\
        Sets a buffer zone between the region inside the horizon and the
        region where the mask is 0 with a width of at least ahf\_maskbuffer
        grid points. The default value is 5.
\end{itemize}
\subsection{Minimal parameter settings}
Usually only a few of the parameters described above are needed in the
parameter file. The simplest parameter settings for using the flow
algorithm for a full 3D horizon with a large sphere as initial guess is
{\tt
\begin{verbatim}
interpolation_order = 2     # Second order interpolation
ahf_active          = "yes"
ahf_flow            = "yes"
ahf_phi             = "yes"
\end{verbatim}
}
This looks for a non-axisymmetric horizon around the origin with lmax = 8
and using the flow algorithm. It starts with the largest sphere that fits
in the 3D grid and outputs 2D grid functions. The other parameters can be
used if needed.
\subsection{Hints for parameter settings}
In full 3D the flow algorithm is faster than the minimization algorithm.
However, in cases when there are very few terms in the expansion in
spherical harmonics the minimization can be faster. In axisymmetry this
typically happens for lmax$\leq 10$.

While the default settings usually work fine, they can be changed to meet
special purposes:
\begin{itemize}
\item If the horizon is expected to be far from spherical the parameter
    ahf\_lmax can be set to a higher value. 12 should be high enough.
    However, only values up to 20 are supported.
\item If the latter parameter is set to a value higher than 8 then the
    parameter ahf\_maxiter can be raised to, e.g., 14. This can be useful
    since more iterations can be necessary for higher coefficients of the
    expansion.
\end{itemize}
\subsection{Output to Files}
The output of the thorn consists of two gridfunctions and several one
dimensional output files.
\begin{itemize}
\item To depict the position of the horizon, the most important files are
    ahfgrid\_2d\_...ieee. These files contain a 2D gridfunction whose zero
    level locates the horizon.
\item The files ahf\_exp\_2d\_...ieee show the expansion of outgoing photons
    on the level set of the gridfunction ahfgrid. The horizon coincides
    with zeros of the expansion.
\item The surface area of the horizon is given in ahf\_area.tl
\item The mass of the horizon is given in ahf\_mass.tl
\item The coefficients of the expansion in spherical harmonics are given in
    ahf\_coeff.alm.
\item The files ahf\_circ\_eq.tl, ahf\_meri\_p1.tl and ahf\_meri\_p2.tl contain
    the equatorial circumference of the surface, the length of the
    meridian at $\phi=0$, and the length of the meridian at $\phi=\pi/2$ of the
    surface, respectively.
\item If an output of a logfile is set in the parameters, the log file for
    the last time the horizon was called is ahf\_logfile.

\end{itemize}
\subsection{Some results with the finder}
The finder has been examined with puncture initial data for single and
binary-black hole scenarios.

Calculations with different grid spacings but constant grid size show
convergence of the horizon area.

This has been checked with different linear momenta in the z direction
$P_{z}=(0M,2M,5M)$ and vanishing spin. Also for $P_{z}=2M$ and a spin of $5M$
in the x direction the horizon converges. 
Figure~\ref{CactusEistein_AHFinder_p2_conv} shows the case with
$P_{z}=2M$ and vanishing spin.

\begin{figure}[ht]
\begin{center}
\includegraphics[angle=0,width=8cm]{p2_areacomp}
\end{center}
\caption{Convergence of the horizon area for $P_{z}=2M$}
\label{CactusEistein_AHFinder_p2_conv}
\end{figure}

Further, not only the area converges but also the shape of the horizon.
For both the minimization and the flow algorithm the horizon converges to
the same shape, as can be seen from the coefficients fo the expansion.
The order of convergence for the coefficients is between 1.4 and 1.7.

By using the parameters ahf\_xc, ahf\_yc, ahf\_zc it can also be shown that
the finder also locates horizons which are not centered. This works in
general as long as the surface can be expanded in spherical harmonics
around this point, but the error increases with the off-centering.

The parameter ahf\_r0 can be used e.g. when dealing with two black holes.
If one searches for separate horizons one can center the finder on one of
the locations of the holes and use an initial radius ahf\_r0 smaller than
the coordinate distance of the holes. With this parameter settings the
single horizon can be found faster. But also a setup with an initial
sphere of maximum radius should work at least for the flow algorithm.
This has been checked with puncture data for two holes with vanishing
linear and angular momentum for each hole (equivalent to Brill-Lindquist
data) and is shown in Figure~\ref{CactusEinstein_AHFinder_p2_conv}. 
Here for a coordinate distance of the holes of 1.6M the separated
horizons for the holes are found but no common horizon. For a coordinate
distance of 1.5M a common horizon is found and also single ones, which
are inner surfaces in this case. This coincides with other work where the
critical coordinate distance for a single horizon is between 1.53M and
1.56M (gr-qc/9809004).

\begin{figure}[ht]
\begin{center}
\includegraphics[angle=0,width=10cm]{hori_bl}
\end{center}
\caption{Horizon positions for BL data}
\label{CactusEinstein_AHFinder_p2_conv}
\end{figure}

The dashed lines show inner trapped surfaces in the left figure and the
surface where the algorithm stopped without finding a horizon in the
right figure.

Also the Misner case was checked. Here for $\mu$ = 1.35 a common horizon is
found. For $\mu$ = 1.37 separated horizons are found. From the literature we
know that (e.g. gr-qc/9809004) the critical value of $\mu$ is 1.36. This is
confirmed by the horizon finder.

The information of when a horizon was found can be seen in the
cactus-logfile. There will be output from the thorn even if no horizon
was found.

\begin{thebibliography}{9}

\end{thebibliography}

% Do not delete next line
% END CACTUS THORNGUIDE

\end{document}

```



Reference answer:
src_code: /*@@
  @file      AHFinder_calcsigma.F
  @date      July 1999
  @author    Lars Nerger
  @desc 
             Calculate weight sigma for Nakamura flow
  @enddesc 
@@*/

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

      subroutine AHFinder_calcsigma(CCTK_ARGUMENTS,xp,yp,zp,gupij,sigma)

      use AHFinder_dat

      implicit none

      DECLARE_CCTK_ARGUMENTS
      DECLARE_CCTK_PARAMETERS

      integer nmax
      integer l,m
      integer indx1,indx2
      integer indx,idir,jdir
      
      CCTK_REAL zero, sigma
      CCTK_REAL ni(3),si(3),supi(3),pij(3,3)
      CCTK_REAL ylmi((lmax+1)**2,3)
      CCTK_REAL alm((lmax+1)**2)
      CCTK_REAL xp,yp,zp,er,sum
      CCTK_REAL rho,costheta,sintheta,sinthetal(-1:lmax),prod
      CCTK_REAL zlm0(0:lmax,0:lmax),zlm1(0:lmax,0:lmax)
      CCTK_REAL cosphi,sinphi,cosmphi(0:lmax),sinmphi(0:lmax)
      CCTK_REAL thetax,thetay,thetaz
      CCTK_REAL phix,phiy
      CCTK_REAL c1,c2,c3,metnorm
      CCTK_REAL fi(3)
      CCTK_REAL gupij(3,3)

!     Description of variables
!
!     sigma   Weight of Nakamura Flow


!     **************************
!     ***   DEFINE NUMBERS   ***
!     **************************

      zero    = 0.0D0
      nmax = (lmax+1)**2

!     ******************************************************
!     ***   Calculate gradient of Y_lm(x,y,z)            ***
!     ***   Adopted from thorn_SpectralAHF by Gundlach  ***
!     ******************************************************
      

!     Initialize arrays
      ylmi = zero
      zlm0 = zero
      zlm1 = zero
      ni = zero
      si = zero
      supi = zero
      pij = zero
      alm = zero
      sinthetal = zero
      cosmphi = zero
      sinmphi = zero


!     Calculate quantities in spherical coordinates.
      er = sqrt(xp**2 + yp**2 + zp**2)
      if (er .eq. 0.d0) then
         call CCTK_WARN(0,'r=0 in AHFinder_calcsigma')
      end if
     
C     ********PATCH******************************************
C     Keep away from the z-axis, artificially.
      if (xp**2 + yp**2 .lt. 1.d-16) then
C         write(6,*) 'patch on axis in ylmder2'
         xp = 0.d0
         yp = 1.d-8
      end if

C     Polar angle theta.
      rho = sqrt(xp**2 + yp**2)
      costheta = zp / er
      sintheta = rho / er
C     Array sinthetal(l) contains [sin(theta)]^l
      sinthetal(-1) = 0.d0
      sinthetal(0) = 1.d0
      sinthetal(1) = sintheta
      do l=2,lmax
         sinthetal(l) = sinthetal(l-1) * sinthetal(1)
      end do

C     zlm0 is Y_lm stripped of exp(i m phi) and multiplied by sqrt(4pi).
C     zlm1 and zlm2 are the first and second derivative of zlm0 
C     with respect to theta. l=0 and m=l are treated separately.
C     We only need zlm0,1,2 for positive m.
C     Treat l=0 separately:
      zlm0(0,0) = 1.d0
      zlm1(0,0) = 0.d0

C     Other l>0.
      prod = 1.d0
      do l=1,lmax

C     Initialize m = l:
C     c1 = sqrt(2l+1) * sqrt(2l!) / 2^l / l! 
C     Y_ll = c1 * sin(theta)^l 
C     Y_llp = c1 * l * sin(theta)^(l-1) * costheta
         m = l
         prod = - prod * sqrt(dble(2*l-1) / dble(2*l)) 
         c1 = sqrt(dble(2*l+1)) * prod
         zlm0(l,m) = c1 * sinthetal(l)
         zlm1(l,m) = c1 * dble(l) * sinthetal(l-1) * costheta

C     Recursion relations for the other m:
C     c2 = sqrt[(2l+1)(2l-1)/(l^2-m^2)]
C     c3 = sqrt[((l-1)^2-m^2)(2l=1)/(l^2-m^2)/(2l-3)]
C     Y_lm = c2 Y_l-1,m cos(theta) + c3 Y_l-2,m
C     Y_lmp = c2 Y_l-1,mp cos(theta) + c2 Y_l-1,m + c3 Y_l-2,mp
         m = l-1
         c2 = sqrt(dble((2*l+1)*(2*l-1)) 
     $        / dble(l**2-m**2)) 
         zlm0(l,m) = c2 * zlm0(l-1,m) * costheta
         zlm1(l,m) = c2 * (zlm1(l-1,m) * costheta 
     $           - zlm0(l-1,m) * sintheta) 

         do m=0,l-2
            c2 = sqrt(dble((2*l+1)*(2*l-1)) 
     $           / dble(l**2-m**2)) 
            c3 =sqrt(dble((2*l+1)*((l-1)**2-m**2))
     $           / dble((l**2 - m**2)*(2*l-3))) 
            zlm0(l,m) = c2 * zlm0(l-1,m) * costheta 
     $           - c3 * zlm0(l-2,m)
            zlm1(l,m) = c2 * (zlm1(l-1,m) * costheta 
     $           - zlm0(l-1,m) * sintheta)
     $           - c3 * zlm1(l-2,m)
         end do
      end do


      if (rho .ne. 0.d0) then
C     Azimuth angle phi is defined.
         cosphi = xp / rho
         sinphi = yp / rho
C     First and second derivatives of theta.
         thetax = costheta * cosphi / er
         thetay = costheta * sinphi / er
         thetaz = - sintheta / er
C     First and second derivatives of phi, the angle in the xy-plane.
         phix = - sinphi / rho
         phiy = cosphi / rho
C     Put together arrays of basis functions in the xy plane.
C     The sqrt(2) factor is needed in going from the basis exp(+/-imphi)
C     to the basis cos/sin(mphi).
         cosmphi(0) = 1.d0
         sinmphi(0) = 1.d0
         cosmphi(1) = sqrt(2.d0) * cosphi
         sinmphi(1) = sqrt(2.d0) * sinphi
         do m=2,lmax
            cosmphi(m) = cosmphi(m-1) * cosphi - sinmphi(m-1) * sinphi
            sinmphi(m) = cosmphi(m-1) * sinphi + sinmphi(m-1) * cosphi
         end do
      else
C     See above for a patch that avoids ever getting here.
          call CCTK_WARN(0,'ylmder2 cannot handle axis')
C     For x = y = 0 the following are not defined.
!         cosphi = 7.d77
!         sinphi = 7.d77
!         thetax = 7.d77
!         thetay = 7.d77
!         phix = 7.d77
!         phiy = 7.d77
!         cosmphi = 7.d77
!         sinmphi = 7.d77
C     Only these are defined.
         thetaz = 0.d0
         cosmphi(0) = 1.d0
         sinmphi(0) = 1.d0
      end if

C     Assemble the Y_lm from zlm0 and the basis of functions of phi.
C     Assemble the Y_lm,i and Y_lm,ij in the corresponding manner.
      do l=0,lmax
         do m=0,l
C     These are the values of indx corresponding to (l,m) and (l,-m).
            indx1 = l**2 + 1 + l + m
            indx2 = l**2 + 1 + l - m
C     Ylm,x
            ylmi(indx1,1) = thetax * zlm1(l,m) * cosmphi(m)
     $           - dble(m) * phix * zlm0(l,m) * sinmphi(m)
            ylmi(indx2,1) = thetax * zlm1(l,m) * sinmphi(m) 
     $           + dble(m) * phix * zlm0(l,m) * cosmphi(m)
C     Ylm,y
            ylmi(indx1,2) = thetay * zlm1(l,m) * cosmphi(m)
     $           - dble(m) * phiy * zlm0(l,m) * sinmphi(m)
            ylmi(indx2,2) = thetay * zlm1(l,m) * sinmphi(m) 
     $           + dble(m) * phiy * zlm0(l,m) * cosmphi(m)
C     Ylm,z
            ylmi(indx1,3) = thetaz * zlm1(l,m) * cosmphi(m)
            ylmi(indx2,3) = thetaz * zlm1(l,m) * sinmphi(m)
         end do
      end do

 
!     ********************************
!     ***  First derivatives of r  ***
!     ********************************
    
      ni(1) = xp / er
      ni(2) = yp / er
      ni(3) = zp / er


!     *************************************************************
!     ***   compress c0, cc and cs into alm with single index   ***
!     *************************************************************

      do l=0, lmax
         alm(l**2+l+1) = c0(l)
         do m=1,lmax
            alm(l**2+l+1+m) = cc(l,m)
            alm(l**2+l+1-m) = cs(l,m)
         end do
      end do


!     *******************************************************************
!     ***   Assemble derivatives of f. Recall f = r - h(theta,phi):   ***
!     *******************************************************************

C     Derivatives of r...
C     r,i = n_i and r,ij = (delta_ij - n_i n_j) / r = n_ij
      do idir=1,3
         fi(idir) = ni(idir)
      end do
C     ...and derivatives of -h.
      do indx=1,nmax
         do idir=1,3
            fi(idir) = fi(idir) - alm(indx) * ylmi(indx,idir)
         end do
      end do


!     *************************************************************
!     ***   Assemble normal vector s on surfaces of constant f  ***
!     ***   with indices down.  That is, normal with respect    ***
!     ***   to the physical metric g_ij.                        ***
!     *************************************************************

      metnorm = 0.d0
      do idir=1,3
         do jdir=1,3
            metnorm = metnorm + fi(idir) * fi(jdir) 
     $           * gupij(idir,jdir)
         end do
      end do
      metnorm = sqrt(metnorm)
      do idir=1,3
         si(idir) = fi(idir) / metnorm
      end do

C     Now with indices up, raised by g^ij.
      do idir=1,3
         supi(idir) = 0.d0
         do jdir=1,3
            supi(idir) = supi(idir) 
     $           + gupij(idir,jdir) * si(jdir) 
         end do
      end do

!     *******************************************************
!     ***   Assemble projection operator with indices up  ***
!     ***            p^ij = g^ij - s^i s^j                ***
!     *******************************************************

      do idir=1,3
         do jdir=1,3
            pij(idir,jdir) = gupij(idir,jdir)
     $           - supi(idir) * supi(jdir)
         end do
      end do


!     *************************************************
!     ***   Calculate weight sigma                  ***
!     ***   2 * r^2 / (p^ij (delta_ij - n_i n_j))   ***
!     *************************************************

      sum = 0.d0
      do idir=1,3
         sum = sum + pij(idir,idir)
         do jdir=1,3
            sum = sum 
     $           - pij(idir,jdir) * ni(idir) * ni(jdir)
         end do
      end do
      sigma = 2.d0 * er**2 / sum


!     ***************
!     ***   END   ***
!     ***************

      end subroutine AHFinder_calcsigma