Task: Implement qlm_tetrad.F90 for EinsteinAnalysis/QuasiLocalMeasures thorn

thorn_name: EinsteinAnalysis/QuasiLocalMeasures
src_filename: qlm_tetrad.F90
interface: # Interface definition for thorn QuasiLocalMeasures

IMPLEMENTS: QuasiLocalMeasures

INHERITS: ADMBase SphericalSurface TmunuBase



CCTK_POINTER_TO_CONST \
FUNCTION GetMPICommWorld (CCTK_POINTER_TO_CONST IN cctkGH)
USES FUNCTION GetMPICommWorld

# translate SphericalSurface name into ID
CCTK_INT \
FUNCTION sf_IdFromName (CCTK_INT IN id, CCTK_POINTER_TO_CONST IN name)
USES FUNCTION sf_IdFromName



INT qlm_state[num_surfaces] TYPE=scalar
{
  qlm_calc_error          # some QLM information is invalid
  qlm_have_valid_data     # interpolating from the AH was successful
  qlm_have_killing_vector # we found a Killing vector field
  qlm_timederiv_order     # order of time derivatives
  qlm_iteration           # iteration for current data
} "Status information"

INT qlm_state_p[num_surfaces] TYPE=scalar
{
  qlm_have_valid_data_p qlm_have_valid_data_p_p
  qlm_have_killing_vector_p qlm_have_killing_vector_p_p
} "Previous status information"
  
INT qlm_grid_int[num_surfaces] TYPE=scalar
{
  qlm_nghoststheta qlm_nghostsphi
  qlm_ntheta qlm_nphi
} "Grid description"

REAL qlm_grid_real[num_surfaces] TYPE=scalar
{
  qlm_origin_x qlm_origin_y qlm_origin_z
  qlm_origin_theta qlm_origin_phi
  qlm_delta_theta qlm_delta_phi
} "Grid description"

REAL qlm_grid_real_p[num_surfaces] TYPE=scalar
{
  qlm_origin_x_p qlm_origin_y_p qlm_origin_z_p
  qlm_origin_x_p_p qlm_origin_y_p_p qlm_origin_z_p_p
} "Previous grid description"

REAL qlm_shapes[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='convergence_power=1'
{
  qlm_shape
} "Shape of the surface"

REAL qlm_shapes_p[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='convergence_power=1'
{
  qlm_shape_p qlm_shape_p_p
} "Previous shapes of the surface"

REAL qlm_coordinates[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='convergence_power=1'
{
  qlm_x qlm_y qlm_z
} "Cartesian coordinates of the grid points on the surface"

# TODO: make this group private, i.e., move it into qlm_variables.F90
REAL qlm_coordinates_p[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='convergence_power=1'
{
  qlm_x_p qlm_y_p qlm_z_p
  qlm_x_p_p qlm_y_p_p qlm_z_p_p
} "Past Cartesian coordinates of the grid points on the surface"

REAL qlm_tetrad_l[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='convergence_power=1'
{
  # all components are contravariant
  qlm_l0 qlm_l1 qlm_l2 qlm_l3       # outward null normal
} "Tetrad vector l^mu"

REAL qlm_tetrad_n[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='convergence_power=1'
{
  # all components are contravariant
  qlm_n0 qlm_n1 qlm_n2 qlm_n3       # inward null normal
} "Tetrad vector n^mu"

COMPLEX qlm_tetrad_m[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='convergence_power=1'
{
  # all components are contravariant
  qlm_m0 qlm_m1 qlm_m2 qlm_m3       # null normal within surface
} "Tetrad vector m^mu"

COMPLEX qlm_newman_penrose[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='Checkpoint="no"' TAGS='convergence_power=1'
{
  qlm_npkappa qlm_nptau qlm_npsigma qlm_nprho
  qlm_npepsilon qlm_npgamma qlm_npbeta qlm_npalpha
  qlm_nppi qlm_npnu qlm_npmu qlm_nplambda
#  qlm_lie_l_npsigma
#  qlm_lie_n_npsigma # for the Bondi mass
} "Newman-Penrose quantities"

COMPLEX qlm_weyl_scalars[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='Checkpoint="no"' TAGS='convergence_power=1'
{
  qlm_psi0 # should be zero for an IH
  qlm_psi1 # should be zero for an IH
  qlm_psi2 # Im Psi_2 defines the angular momentum
  qlm_psi3
  qlm_psi4
  qlm_i qlm_j # curvature invariants I and J
  qlm_s      # speciality index S = 27 J^2 / I^3
  qlm_sdiff  # (27 J^2 - I^3) / L_2[Psi_n]^3
} "Weyl scalars (aka Newman-Penrose spin coefficients)"

REAL qlm_ricci_scalars[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='Checkpoint="no"' TAGS='convergence_power=1'
{
  qlm_phi00                     # Ricci tensor
  qlm_phi11
  qlm_phi01
  qlm_phi12
  qlm_phi10
  qlm_phi21
  qlm_phi02
  qlm_phi22
  qlm_phi20
  
  qlm_lambda                    # Ricci scalar
  
  qlm_lie_n_theta_l             # Lie_n Theta_(l)
} "Ricci scalars"

REAL qlm_twometric[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='Checkpoint="no"' TAGS='convergence_power=1'
{
  qlm_qtt qlm_qtp qlm_qpp
  qlm_rsc                       # 2-Ricci scalar
} "2-metric"

REAL qlm_killing_vector[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='convergence_power=1'
{
  qlm_xi_t qlm_xi_p
  qlm_chi
} "Killing vector field"

REAL qlm_killed_twometric[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='Checkpoint="no"' TAGS='convergence_power=1'
{
  qlm_lqtt qlm_lqtp qlm_lqpp
} "Lie derivative of the 2-metric along the Killing vector field"

REAL qlm_invariant_coordinates[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='Checkpoint="no"' TAGS='convergence_power=1'
{
  qlm_inv_z
} "Invariant coordinates on the surface, assuming axisymmetry"

REAL qlm_multipole_moments[num_surfaces] TYPE=scalar TAGS='Checkpoint="no"'
{
  qlm_mp_m0 qlm_mp_m1 qlm_mp_m2 qlm_mp_m3 qlm_mp_m4 qlm_mp_m5 qlm_mp_m6 qlm_mp_m7 qlm_mp_m8
  qlm_mp_j0 qlm_mp_j1 qlm_mp_j2 qlm_mp_j3 qlm_mp_j4 qlm_mp_j5 qlm_mp_j6 qlm_mp_j7 qlm_mp_j8
} "Mass and spin multipole moments"

REAL qlm_3determinant[num_surfaces] TYPE=array DIM=2 SIZE=SphericalSurface::maxntheta,SphericalSurface::maxnphi DISTRIB=constant TAGS='Checkpoint="no"' TAGS='convergence_power=1'
{
  qlm_3det
} "3-Determinant of H for a special choice of the triad"

REAL qlm_scalars[num_surfaces] TYPE=scalar
{
  qlm_time
  qlm_equatorial_circumference
  qlm_polar_circumference_0
  qlm_polar_circumference_pi_2
  # area A and areal radius R
  qlm_area qlm_irreducible_mass qlm_radius
  qlm_spin_guess qlm_mass_guess
  qlm_killing_eigenvalue_re qlm_killing_eigenvalue_im
  # spin J: J = a M^2, i.e., angular momentum (spin is a misnomer)
  qlm_spin qlm_npspin qlm_wsspin qlm_cvspin
  qlm_coordspinx qlm_coordspiny qlm_coordspinz
  # mass M : total mass, i.e., including angular momentum
  qlm_mass
  qlm_adm_energy
  qlm_adm_momentum_x qlm_adm_momentum_y qlm_adm_momentum_z
  qlm_adm_angular_momentum_x qlm_adm_angular_momentum_y qlm_adm_angular_momentum_z
  qlm_w_energy
  qlm_w_momentum_x qlm_w_momentum_y qlm_w_momentum_z
  qlm_w_angular_momentum_x qlm_w_angular_momentum_y qlm_w_angular_momentum_z
} "Scalar quantities on the surface"

REAL qlm_scalars_p[num_surfaces] TYPE=scalar
{
  qlm_time_p qlm_time_p_p
  qlm_radius_p qlm_radius_p_p
} "Some scalar quantities on the surface at previous times"

schedule: # Schedule definitions for thorn QuasiLocalMeasures

STORAGE: qlm_state qlm_scalars
STORAGE: qlm_state_p qlm_scalars_p
STORAGE: qlm_grid_int qlm_grid_real qlm_grid_real_p
STORAGE: qlm_shapes qlm_tetrad_l qlm_tetrad_n qlm_tetrad_m
STORAGE: qlm_shapes_p
STORAGE: qlm_killing_vector



# These variables need storage so that they can be output
STORAGE: qlm_coordinates qlm_coordinates_p
STORAGE: qlm_newman_penrose qlm_weyl_scalars
STORAGE: qlm_ricci_scalars qlm_twometric qlm_killed_twometric
STORAGE: qlm_invariant_coordinates qlm_multipole_moments qlm_3determinant



SCHEDULE qlm_paramcheck AT paramcheck
{
  OPTIONS: global
  LANG: Fortran
} "Check quasi-local parameter settings"

SCHEDULE qlm_init AT initial
{
  OPTIONS: global
  LANG: Fortran
} "Initialise quasi-local calculations"

SCHEDULE qlm_calculate AT analysis AFTER (SphericalSurface_HasBeenSet SetTmunu)
{
  OPTIONS: global
  LANG: Fortran
  STORAGE: qlm_coordinates qlm_coordinates_p
  STORAGE: qlm_newman_penrose qlm_weyl_scalars
  STORAGE: qlm_ricci_scalars qlm_twometric qlm_killed_twometric 
  STORAGE: qlm_invariant_coordinates qlm_multipole_moments qlm_3determinant
  TRIGGERS: qlm_state
  TRIGGERS: qlm_grid_int qlm_grid_real
  TRIGGERS: qlm_shapes qlm_tetrad_l qlm_tetrad_n qlm_tetrad_m
  TRIGGERS: qlm_coordinates
  TRIGGERS: qlm_newman_penrose qlm_weyl_scalars
  TRIGGERS: qlm_ricci_scalars qlm_twometric qlm_killing_vector qlm_killed_twometric
  TRIGGERS: qlm_invariant_coordinates qlm_multipole_moments qlm_3determinant
  TRIGGERS: qlm_scalars
} "Calculate quasi-local quantities"

param: # Parameter definitions for thorn QuasiLocalMeasures

BOOLEAN verbose "Produce log output while running" STEERABLE=always
{
} "no"

BOOLEAN veryverbose "Produce much log output while running" STEERABLE=always
{
} "no"



INT num_surfaces "Number of surfaces"
{
  0:100 :: ""
} 1



INT surface_index[100] "Spherical surface that contains the surface shape"
{
  -1  :: "do not calculate"
  0:* :: "surface index"
} -1

STRING surface_name[100] "Spherical surface that contains the surface shape"
{
  ""   :: "use surface_index"
  ".*" :: "surface name"
} ""

STRING coordsystem "The coordinate system to use" STEERABLE=always
{
  "" :: "must be a registered coordinate system"
} "cart3d"

STRING interpolator "The interpolator to use" STEERABLE=always
{
  "" :: "must be a registered interpolator"
} "Lagrange polynomial interpolation"

STRING interpolator_options "Options for the interpolator" STEERABLE=always
{
  "" :: "must be a valid options specification"
} "order=2"



INT spatial_order "Order of spatial differencing"
{
  2 :: "second order"
  4 :: "fourth order"
} 2



REAL begin_qlm_calculations_after[100] "when should we start calculations?" STEERABLE=always
{
  *:* :: "at/after this time (inclusively)"
} 0.0



KEYWORD killing_vector_method "Method for finding the Killing vector field" STEERABLE=always
{
  "axial"       :: "Assume that d/dphi is a Killing vector"
  "eigenvector" :: "Solve the Killing vector equation as eigenvector equation"
  "gradient"    :: "Calculate the normal to the gradient of a scalar"
} "eigenvector"

KEYWORD killing_vector_normalisation "Method for normalising the Killing vector field" STEERABLE=always
{
  "average" :: "Average several integral lines"
  "median"  :: "Use the median integral line"
} "average"

INT output_vtk_every "Output a VTK file with the main 2D" STEERABLE=always
{
  0   :: "don't output VTK file"
  1:* :: "output every so many iterations"
} 0


SHARES: ADMBase

USES KEYWORD metric_type



SHARES: SphericalSurface

USES INT nsurfaces

USES BOOLEAN auto_res

USES INT maxntheta
USES INT maxnphi

USES INT ntheta
USES INT nphi
USES INT nghoststheta
USES INT nghostsphi

USES BOOLEAN symmetric_x
USES BOOLEAN symmetric_y
USES BOOLEAN symmetric_z

configuration: # Configuration definition for thorn QuasiLocalMeasures

REQUIRES Boundary Fortran LAPACK TGRtensor

OPTIONAL MPI
{
}

context: qlm_killing_gradient.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_killing_gradient (CCTK_ARGUMENTS, hn)
  use cctk
  use constants
  use qlm_boundary
  use qlm_derivs
  use tensor2
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL, parameter :: two=2, half=1/two
  CCTK_REAL :: qq(2,2), dqq(2,2,2), dtq, qu(2,2), dqu(2,2,2)
  CCTK_REAL :: dpsi2(2), ddpsi2(2,2), ndpsi2, dndpsi2(2)
  CCTK_REAL :: xi(2), dxi(2,2), chi
  integer   :: i, j
  integer   :: a, b
  CCTK_REAL    :: delta_space(2)
  
  delta_space(:) = (/ qlm_delta_theta(hn), qlm_delta_phi(hn) /)
  
  ! Calculate the gradient of a scalar
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        
        ! 2-metric on the horizon
        qq(1,1) = qlm_qtt(i,j,hn)
        qq(1,2) = qlm_qtp(i,j,hn)
        qq(2,2) = qlm_qpp(i,j,hn)
        qq(2,1) = qq(1,2)
        
#if 0
        dqq(1,1,1) = qlm_dqttt(i,j)
        dqq(1,1,2) = qlm_dqttp(i,j)
        dqq(1,2,1) = qlm_dqtpt(i,j)
        dqq(1,2,2) = qlm_dqtpp(i,j)
        dqq(2,2,1) = qlm_dqppt(i,j)
        dqq(2,2,2) = qlm_dqppp(i,j)
        dqq(2,1,:) = dqq(1,2,:)
#endif
        
        call calc_2det (qq, dtq)
#if 0
        call calc_2inv (qq, dtq, qu)
        call calc_2invderiv (qu, dqq, dqu)
#endif
        
        dpsi2(1) = (abs2(qlm_psi2(i+1,j,hn)) - abs2(qlm_psi2(i-1,j,hn))) / (2*qlm_delta_theta(hn))
        dpsi2(2) = (abs2(qlm_psi2(i,j+1,hn)) - abs2(qlm_psi2(i,j-1,hn))) / (2*qlm_delta_phi(hn))
        
#if 0
        ddpsi2(1,1) = (abs2(qlm_psi2(i+1,j,hn)) - 2*abs2(qlm_psi2(i,j,hn)) + abs2(qlm_psi2(i-1,j,hn))) / qlm_delta_theta(hn)**2
        ddpsi2(2,2) = (abs2(qlm_psi2(i,j+1,hn)) - 2*abs2(qlm_psi2(i,j,hn)) + abs2(qlm_psi2(i,j-1,hn))) / qlm_delta_phi(hn)**2
        ddpsi2(1,1) = (abs2(qlm_psi2(i-1,j-1,hn)) - abs2(qlm_psi2(i+1,j-1,hn)) - abs2(qlm_psi2(i-1,j+1,hn)) + abs2(qlm_psi2(i+1,j+1,hn))) / (4*qlm_delta_theta(hn)*qlm_delta_phi(hn))
        ddpsi2(2,1) = ddpsi2(1,2)
        
        ! ndpsi2 = ||grad |Psi_2|^2||
        ndpsi2 = 0
        do a=1,2
           do b=1,2
              ndpsi2 = ndpsi2 + qu(a,b) * dpsi2(a) * dpsi2(b)
           end do
        end do
        ndpsi2 = sqrt(ndpsi2)
        
        ! dndpsi2 = grad ||grad |Psi_2|^2||
        do a=1,2
           dndpsi2(a) = 0
           do b=1,2
              do c=1,2
                 dndpsi2(a) = dndpsi2(a) + 1 / (2*ndpsi2) * (qu(b,c) * ddpsi2(b,a) * dpsi2(c) + qu(b,c) * dpsi2(b) * ddpsi2(c,a) + dqu(b,c,a) * dpsi2(b) * dpsi2(c))
              end do
           end do
        end do
#endif
        
        ! xi^a = eps^ab D_b |Psi_2|^2
        do a=1,2
           xi(a) = 0
           do b=1,2
              xi(a) = xi(a) + sqrt(dtq) * epsilon2(a,b) * dpsi2(b)
           end do
        end do
        
        qlm_xi_t(i,j,hn) = xi(1)
        qlm_xi_p(i,j,hn) = xi(2)
        
#if 0
        ! xi^a = eps^ab D_b ||D_c |Psi_2|^2||
        do a=1,2
           xi(a) = 0
           do b=1,2
              xi(a) = xi(a) + sqrt(dtq) * epsilon2(a,b) * dndpsi2(b)
           end do
        end do
        
        qlm_xi_t(i,j,hn) = xi(1)
        qlm_xi_p(i,j,hn) = xi(2)
#endif
        
     end do
  end do
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_xi_t(:,:,hn), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_xi_p(:,:,hn), -1)
  
  
  
  ! fix up xi (which must not be zero)
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        
        xi(1) = qlm_xi_t(i,j,hn)
        xi(2) = qlm_xi_p(i,j,hn)
        
        if (sum(xi**2) < 1.0d-4**2) then
           
           qlm_xi_t(i,j,hn) = sum(qlm_xi_t(i:i+1,j:j+1,hn)) / 4
           qlm_xi_p(i,j,hn) = sum(qlm_xi_p(i:i+1,j:j+1,hn)) / 4
           
        end if
        
     end do
  end do
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_xi_t(:,:,hn), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_xi_p(:,:,hn), -1)
  
  
  
  ! set up the derivative of xi (which is not really needed)
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        
        ! 2-metric on the horizon
        qq(1,1) = qlm_qtt(i,j,hn)
        qq(1,2) = qlm_qtp(i,j,hn)
        qq(2,2) = qlm_qpp(i,j,hn)
        qq(2,1) = qq(1,2)
        call calc_2det (qq, dtq)
        
        dxi(1,1:2) = deriv (qlm_xi_t(:,:,hn), i, j, delta_space)
        dxi(2,1:2) = deriv (qlm_xi_p(:,:,hn), i, j, delta_space)
        
        ! eps_ab sqrt(q) chi = D_b xi_a
        !        sqrt(q) chi = -1/2 eps^ab D_a xi_b
        chi = 0
        do a=1,2
           do b=1,2
              chi = chi - half * sqrt(dtq) * epsilon2(a,b) * dxi(b,a)
           end do
        end do
        
        qlm_chi(i,j,hn) = chi
        
     end do
  end do
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_chi (:,:,hn), +1)
  
end subroutine qlm_killing_gradient

```

qlm_derivs.F90:
```
#include "cctk.h"
#include "cctk_Parameters.h"

module qlm_derivs
  use classify
  implicit none
  private
  public abs2
  public operator(.outer.)
  public operator(.dot.)
  public deriv
  public deriv2
  public timederiv
  
  interface deriv
     module procedure rderiv
  end interface
  
  interface deriv2
     module procedure rderiv2
  end interface
  
  interface timederiv
     module procedure rtimederiv
  end interface
  
  interface operator(.outer.)
     module procedure router
     module procedure couter
  end interface
  
  interface operator(.dot.)
     module procedure rdot
     module procedure cdot
  end interface
  
contains
  
  ! abs(c)**2 for complex c without a square root
  pure elemental function abs2 (a)
    CCTK_COMPLEX, intent(in) :: a
    CCTK_REAL :: abs2
    abs2 = a * conjg(a)
  end function abs2
  
  
  
  function router (left, right) result (result)
    CCTK_REAL, intent(in) :: left(:), right(:)
    CCTK_REAL             :: result(size(left,1),size(right,1))
    integer :: i, j
    forall (i=1:size(left,1), j=1:size(right,1))
       result(i,j) = left(i) * right(j)
    end forall
  end function router
  
  function couter (left, right) result (result)
    CCTK_COMPLEX, intent(in) :: left(:), right(:)
    CCTK_COMPLEX             :: result(size(left,1),size(right,1))
    integer :: i, j
    forall (i=1:size(left,1), j=1:size(right,1))
       result(i,j) = left(i) * right(j)
    end forall
  end function couter
  
  
  
  function rdot (left, right) result (result)
    CCTK_REAL, intent(in) :: left(:), right(:)
    CCTK_REAL             :: result
    integer :: i
    if (size(left,1) /= size(right,1)) then
       call CCTK_WARN (0, "Array sizes must have the same sizes")
    end if
!!$    result = sum((/( left(i) * right(i), i=1,size(left,1) )/))
    result = 0
    do i=1,size(left,1)
       result = result + left(i) * right(i)
    end do
  end function rdot
  
  function cdot (left, right) result (result)
    CCTK_COMPLEX, intent(in) :: left(:), right(:)
    CCTK_COMPLEX             :: result
    integer :: i
    if (size(left,1) /= size(right,1)) then
       call CCTK_WARN (0, "Array sizes must have the same sizes")
    end if
!!$    result = sum((/( left(i) * right(i), i=1,size(left,1) )/))
    result = 0
    do i=1,size(left,1)
       result = result + left(i) * right(i)
    end do
  end function cdot
  
  
  
  ! Calculate spatial derivatives
  
  pure function rderiv (f, i, j, dx) result (df)
    DECLARE_CCTK_PARAMETERS
    CCTK_REAL, intent(in)           :: f(:,:)
    integer,   intent(in)           :: i, j
    CCTK_REAL, intent(in)           :: dx(2)
    CCTK_REAL                       :: df(2)
    
    select case (spatial_order)
    case (2)
       df(1) = (+ f(i+1,j) - f(i-1,j)) / (2 * dx(1))
       df(2) = (+ f(i,j+1) - f(i,j-1)) / (2 * dx(2))
    case (4)
       df(1) = (- f(i+2,j) + 8*f(i+1,j) - 8*f(i-1,j) + f(i-2,j)) / (12 * dx(1))
       df(2) = (- f(i,j+2) + 8*f(i,j+1) - 8*f(i,j-1) + f(i,j-2)) / (12 * dx(2))
    case default
       ! call CCTK_WARN (0, "internal error")
       df = TAT_nan()
    end select
  end function rderiv
  
  pure function rderiv2 (f, i, j, dx) result (ddf)
    DECLARE_CCTK_PARAMETERS
    CCTK_REAL, intent(in) :: f(:,:)
    integer,   intent(in) :: i, j
    CCTK_REAL, intent(in) :: dx(2)
    CCTK_REAL             :: ddf(2,2)
    
    select case (spatial_order)
    case (2)
       ddf(1,1) = (+ f(i+1,j) - 2*f(i,j) + f(i-1,j)) / dx(1)**2
       ddf(2,2) = (+ f(i,j+1) - 2*f(i,j) + f(i,j-1)) / dx(2)**2
       ddf(1,2) = (+ f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1)) &
             &    / (4 * dx(1) * dx(2))
       ddf(2,1) = ddf(1,2)
    case (4)
       ddf(1,1) &
            = (- f(i+2,j) + 16*f(i+1,j) - 30*f(i,j) + 16*f(i-1,j) - f(i-2,j)) &
            & / (12 * dx(1)**2)
       ddf(2,2) &
            = (- f(i,j+2) + 16*f(i,j+1) - 30*f(i,j) + 16*f(i,j-1) - f(i,j-2)) &
            & / (12 * dx(2)**2)
       ddf(1,2) &
            = (+   f(i+2,j+2) -  8*f(i+1,j+2) +  8*f(i-1,j+2) -   f(i-2,j+2)  &
            &  - 8*f(i+2,j+1) + 64*f(i+1,j+1) - 64*f(i-1,j+1) + 8*f(i-2,j+1)  &
            &  + 8*f(i+2,j-1) - 64*f(i+1,j-1) + 64*f(i-1,j-1) - 8*f(i-2,j-1)  &
            &  -   f(i+2,j-2) +  8*f(i+1,j-2) -  8*f(i-1,j-2) +   f(i-2,j-2)) &
            & / (144 * dx(1) * dx(2))
       ddf(2,1) = ddf(1,2)
    case default
       ! call CCTK_WARN (0, "internal error")
       ddf = TAT_nan()
    end select
  end function rderiv2
  
  
  
  ! Calculate a time derivate from several time levels
  pure elemental function rtimederiv (f0, f1, f2, t0, t1, t2, ce0, ce1, ce2) result (fdot)
    CCTK_REAL, intent(in) :: f0, f1, f2
    CCTK_REAL, intent(in) :: t0, t1, t2
    logical,   intent(in) :: ce0, ce1, ce2
    CCTK_REAL             :: fdot
    CCTK_REAL :: dt1, dt2
    CCTK_REAL :: fdot1, fdot2
    
!!$    dt1 = qlm_time(hn) - qlm_time_p(hn)
!!$    dt2 = qlm_time(hn) - qlm_time_p_p(hn)
    dt1 = t0 - t1
    dt2 = t0 - t2
    
    if (ce0 .or. ce1) then
       fdot = 0
    else if (ce2) then
       fdot = (f0 - f1) / dt1
    else
       ! f(dt1) = f(0) + dt1 f'(0) + dt1^2/2 f''(0)
       ! f(dt2) = f(0) + dt2 f'(0) + dt2^2/2 f''(0)
       ! f'(0) = [f(dt1) - f(0)] / dt1 - dt1/2 f''(0)
       ! f'(0) = [f(dt2) - f(0)] / dt2 - dt2/2 f''(0)
       fdot1 = (f0 - f1) / dt1
       fdot2 = (f0 - f2) / dt2
       fdot = (fdot1 * dt2 - fdot2 * dt1) / (dt2 - dt1)
    end if
  end function rtimederiv
  
end module qlm_derivs

```

qlm_killing_transportation.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



module qlm_killing_transportation
  use cctk
  use constants
  use qlm_variables
  use ricci2
  use tensor2
  implicit none
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  private
  public transport_along_equator
  public transport_along_meridians
  
contains
  
  subroutine transport_along_equator (CCTK_ARGUMENTS, hn, i0, xi, chi)
    DECLARE_CCTK_ARGUMENTS
    integer,   intent(in)    :: hn
    integer,   intent(in)    :: i0
    CCTK_REAL, intent(inout) :: xi(2), chi
    integer :: j0
    integer :: nsteps
    
    j0 = 1+qlm_nghostsphi(hn)
    nsteps = qlm_nphi(hn) - 2*qlm_nghostsphi(hn)
    
    call transport (CCTK_PASS_FTOF, hn, i0, j0, 0, 1, nsteps, xi, chi)
    
  end subroutine transport_along_equator
  
  
  
  subroutine transport_along_meridians (CCTK_ARGUMENTS, hn, i0)
    DECLARE_CCTK_ARGUMENTS
    integer, intent(in) :: hn
    integer, intent(in) :: i0
    CCTK_REAL :: xi(2), chi
    integer   :: j0
    integer   :: dir
    integer   :: nsteps
    
    do j0 = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
       
       do dir=-1,+1,2
          
          if (dir==-1) nsteps = i0 - (1+qlm_nghoststheta(hn))
          if (dir==+1) nsteps = (qlm_ntheta(hn)-qlm_nghoststheta(hn)) - i0
          
          xi(1) = qlm_xi_t(i0,j0,hn)
          xi(2) = qlm_xi_p(i0,j0,hn)
          chi = qlm_chi(i0,j0,hn)
          
          call transport (CCTK_PASS_FTOF, hn, i0, j0, dir, 0, nsteps, xi, chi)
          
       end do
       
    end do
    
  end subroutine transport_along_meridians
  
  
  
  subroutine transport (CCTK_ARGUMENTS, hn, i0, j0, di, dj, nsteps, xi, chi)
    DECLARE_CCTK_ARGUMENTS
    integer,  intent(in)    :: hn
    integer,  intent(in)    :: i0, j0
    integer,  intent(in)    :: di, dj
    integer,  intent(in)    :: nsteps
    CCTK_REAL,intent(inout) :: xi(2), chi
    CCTK_REAL :: vv(2)
    CCTK_REAL :: xi_dot(2), chi_dot
    CCTK_REAL :: xi1(2), chi1
    CCTK_REAL :: xi1_dot(2), chi1_dot
    integer   :: n
    integer   :: i, j
    
    i = i0
    j = j0
    
    vv(1) = di * qlm_delta_theta(hn)
    vv(2) = dj * qlm_delta_phi(hn)
    
    do n=1,nsteps
       
       call transport_rhs (CCTK_PASS_FTOF, hn, i, j, xi, chi, vv, xi_dot, chi_dot)
       xi1 = xi + xi_dot
       chi1 = chi + chi_dot
       i = i + di
       j = j + dj
       if (j <           1+qlm_nghostsphi(hn)) j = j + (qlm_nphi(hn)-2*qlm_nghostsphi(hn))
       if (j > qlm_nphi(hn)-qlm_nghostsphi(hn)) j = j - (qlm_nphi(hn)-2*qlm_nghostsphi(hn))
       
       call transport_rhs &
            (CCTK_PASS_FTOF, hn, i, j, xi1, chi1, vv, xi1_dot, chi1_dot)
       xi = xi + 0.5d0 * (xi_dot + xi1_dot)
       chi = chi + 0.5d0 * (chi_dot + chi1_dot)
       
       qlm_xi_t(i,j,hn) = xi(1)
       qlm_xi_p(i,j,hn) = xi(2)
       qlm_chi(i,j,hn) = chi

    end do
    
  end subroutine transport
  
  
  
  subroutine transport_rhs (CCTK_ARGUMENTS, hn, i, j, xi, chi, vv, xi_dot, chi_dot)
    DECLARE_CCTK_ARGUMENTS
    integer,   intent(in)  :: hn
    integer,   intent(in)  :: i, j
    CCTK_REAL, intent(in)  :: xi(2), chi
    CCTK_REAL, intent(in)  :: vv(2)
    CCTK_REAL, intent(out) :: xi_dot(2), chi_dot
    CCTK_REAL :: qq(2,2), dqq(2,2,2), dtq, qu(2,2), gamma(2,2,2), rsc
    
    if (i<1+qlm_nghoststheta(hn) .or. i>qlm_ntheta(hn)-qlm_nghoststheta(hn) &
         .or. j<1+qlm_nghostsphi(hn) .or. j>qlm_nphi(hn)-qlm_nghostsphi(hn)) then
       call CCTK_WARN (0, "internal error")
    end if
    if (i-1<1 .or. i+1>qlm_ntheta(hn) .or. j-1<1 .or. j+1>qlm_nphi(hn)) then
       call CCTK_WARN (0, "internal error")
    end if
    
    qq(1,1) = qlm_qtt(i,j,hn)
    qq(1,2) = qlm_qtp(i,j,hn)
    qq(2,2) = qlm_qpp(i,j,hn)
    qq(2,1) = qq(1,2)
    
    dqq(1,1,1) = qlm_dqttt(i,j)
    dqq(1,2,1) = qlm_dqtpt(i,j)
    dqq(2,2,1) = qlm_dqppt(i,j)
    dqq(1,1,2) = qlm_dqttp(i,j)
    dqq(1,2,2) = qlm_dqtpp(i,j)
    dqq(2,2,2) = qlm_dqppp(i,j)
    dqq(2,1,:) = dqq(1,2,:)
    
    rsc = qlm_rsc(i,j,hn)
    
    call calc_2det (qq, dtq)
    call calc_2inv (qq, dtq, qu)
    
    call calc_2connections (qu, dqq, gamma)
    
    call killing_transport_rhs &
         (xi, chi, qq, dtq, qu, gamma, rsc, vv, xi_dot, chi_dot)
    
  end subroutine transport_rhs
  
  
  
  subroutine killing_transport_rhs &
       (xi, chi, qq, dtq, qu, gamma2, rsc2, vv, xi_dot, chi_dot)
    CCTK_REAL, intent(in)  :: xi(2), chi
    CCTK_REAL, intent(in)  :: qq(2,2), dtq, qu(2,2), gamma2(2,2,2), rsc2
    CCTK_REAL, intent(in)  :: vv(2)
    CCTK_REAL, intent(out) :: xi_dot(2), chi_dot
    integer :: i, k, l
    
    ! Wald eqn (C.3.6):
    ! D_k D_j xi^i = R^i_jkl xi^l
    
    ! define:
    ! L^i_j = D_j x^i
    
    ! then: see Wald eqns (C.3.7) and (C.3.8):
    ! v^k D_k xi^i = L^i_k v^k
    ! v^k D_k L^i_j = R^i_jkl v^k xi^l
    
    ! in 2D we have:
    ! R_ijkl = 1/2 q R epsilon2_ij epsilon2_kl
    ! L_ij = epsilon2_ij sqrt(q) chi
    
    ! then:
    ! v^k D_k xi^i = epsilon2^i_k sqrt(q) chi v^k
    ! v^k D_k epsilon2^i_j sqrt(q) chi = R^i_jkl v^k xi^l
    ! v^k D_k chi = 1/2 sqrt(q) R epsilon2_kl v^k xi^l
    
    ! define:
    ! X_dot = v^i d/dx^i X   (partial derivatives)
    
    do i=1,2
       xi_dot(i) = 0
       do k=1,2
          do l=1,2
             xi_dot(i) = xi_dot(i) &
                  + qu(i,l) * epsilon2(l,k) * sqrt(dtq) * chi * vv(k) &
                  - vv(k) * gamma2(i,l,k) * xi(l)
          end do
       end do
    end do
    
    chi_dot = 0
    do k=1,2
       do l=1,2
          chi_dot = chi_dot &
               + 0.5d0 * sqrt(dtq) * rsc2 * epsilon2(k,l) * vv(k) * xi(l)
       end do
    end do
    
  end subroutine killing_transport_rhs
  
  
  
#if 0
  subroutine killing_equation (qq, qu, xi, gxi, zeta, trzeta, zetasq)
    CCTK_REAL, intent(in)  :: qq(2,2), qu(2,2)
    CCTK_REAL, intent(in)  :: xi(2), gxi(2,2)
    CCTK_REAL, intent(out) :: zeta(2,2), trzeta, zetasq
    integer :: i, j, k, l
    
    do i=1,2
       do j=1,2
          ! zeta_ij = D_i xi_j + D_j xi_i
          zeta(i,j) = 0
          do k=1,2
             do l=1,2
                zeta(i,j) = zeta(i,j) + qq(j,k) * gxi(k,i) + qq(i,k) * gxi(k,j)
             end do
          end do
       end do
    end do
    
    trzeta = 0
    do i=1,2
       do j=1,2
          trzeta = trzeta + qu(i,j) * zeta(i,j)
       end do
    end do
    
    zetasq = 0
    do i=1,2
       do j=1,2
          do k=1,2
             do l=1,2
                zetasq = zetasq + qu(i,k) * qu(j,l) * zeta(i,j) * zeta(k,l)
             end do
          end do
       end do
    end do
  end subroutine killing_equation
#endif
  
end module qlm_killing_transportation

```

qlm_multipoles.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_multipoles (CCTK_ARGUMENTS, hn)
  use cctk
  use constants
  use qlm_boundary
  use qlm_derivs
  use qlm_variables
  use ricci2
  use tensor2
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL, parameter :: one=1, two=2
  CCTK_REAL, parameter :: half=one/2, fourth=one/4, eighth=one/8
  CCTK_REAL, parameter :: sixteenth=one/16
  CCTK_REAL, parameter :: o128=one/128
  
  CCTK_REAL    :: qq(2,2), dtq, rsc
  CCTK_COMPLEX :: psi2
  CCTK_REAL    :: zz
  CCTK_REAL    :: area, mass, spin
  
  CCTK_REAL    :: delta_space(2)
  
  integer      :: i, j
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Calculating multipole moments")
  end if
  
  delta_space(:) = (/ qlm_delta_theta(hn), qlm_delta_phi(hn) /)
  
  qlm_mp_m0(hn) = 0
  qlm_mp_m1(hn) = 0
  qlm_mp_m2(hn) = 0
  qlm_mp_m3(hn) = 0
  qlm_mp_m4(hn) = 0
  qlm_mp_m5(hn) = 0
  qlm_mp_m6(hn) = 0
  qlm_mp_m7(hn) = 0
  qlm_mp_m8(hn) = 0
  
  qlm_mp_j0(hn) = 0
  qlm_mp_j1(hn) = 0
  qlm_mp_j2(hn) = 0
  qlm_mp_j3(hn) = 0
  qlm_mp_j4(hn) = 0
  qlm_mp_j5(hn) = 0
  qlm_mp_j6(hn) = 0
  qlm_mp_j7(hn) = 0
  qlm_mp_j8(hn) = 0
  
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        
        ! 2-metric on the horizon
        qq(1,1) = qlm_qtt(i,j,hn)
        qq(1,2) = qlm_qtp(i,j,hn)
        qq(2,2) = qlm_qpp(i,j,hn)
        qq(2,1) = qq(1,2)
        
        call calc_2det (qq, dtq)
        
        rsc = qlm_rsc(i,j,hn)
        
        zz = qlm_inv_z(i,j,hn)
        
        area = sqrt(dtq) * qlm_delta_theta(hn) * qlm_delta_phi(hn)
        
        mass = fourth * rsc
        
        qlm_mp_m0(hn) = qlm_mp_m0(hn) + mass * p0(zz) * area
        qlm_mp_m1(hn) = qlm_mp_m1(hn) + mass * p1(zz) * area
        qlm_mp_m2(hn) = qlm_mp_m2(hn) + mass * p2(zz) * area
        qlm_mp_m3(hn) = qlm_mp_m3(hn) + mass * p3(zz) * area
        qlm_mp_m4(hn) = qlm_mp_m4(hn) + mass * p4(zz) * area
        qlm_mp_m5(hn) = qlm_mp_m5(hn) + mass * p5(zz) * area
        qlm_mp_m6(hn) = qlm_mp_m6(hn) + mass * p6(zz) * area
        qlm_mp_m7(hn) = qlm_mp_m7(hn) + mass * p7(zz) * area
        qlm_mp_m8(hn) = qlm_mp_m8(hn) + mass * p8(zz) * area
        
        spin = qlm_spin_density(i,j)
        
        qlm_mp_j0(hn) = qlm_mp_j0(hn) + spin * dp0(zz) * area
        qlm_mp_j1(hn) = qlm_mp_j1(hn) + spin * dp1(zz) * area
        qlm_mp_j2(hn) = qlm_mp_j2(hn) + spin * dp2(zz) * area
        qlm_mp_j3(hn) = qlm_mp_j3(hn) + spin * dp3(zz) * area
        qlm_mp_j4(hn) = qlm_mp_j4(hn) + spin * dp4(zz) * area
        qlm_mp_j5(hn) = qlm_mp_j5(hn) + spin * dp5(zz) * area
        qlm_mp_j6(hn) = qlm_mp_j6(hn) + spin * dp6(zz) * area
        qlm_mp_j7(hn) = qlm_mp_j7(hn) + spin * dp7(zz) * area
        qlm_mp_j8(hn) = qlm_mp_j8(hn) + spin * dp8(zz) * area
        
!!$        spin = 0
!!$        do a=1,2
!!$           do b=1,2
!!$              do c=1,3
!!$                 do d=1,3
!!$                    spin = spin - half * area * epsilon2(a,b) * dzz(b) * ee(d,a) * kk(d,c) * ss(c)
!!$                 end do
!!$              end do
!!$           end do
!!$        end do
!!$        
!!$        qlm_mp_j0(hn) = qlm_mp_j0(hn) + spin * dp0(zz) * area
!!$        qlm_mp_j1(hn) = qlm_mp_j1(hn) + spin * dp1(zz) * area
!!$        qlm_mp_j2(hn) = qlm_mp_j2(hn) + spin * dp2(zz) * area
!!$        qlm_mp_j3(hn) = qlm_mp_j3(hn) + spin * dp3(zz) * area
!!$        qlm_mp_j4(hn) = qlm_mp_j4(hn) + spin * dp4(zz) * area
!!$        qlm_mp_j5(hn) = qlm_mp_j5(hn) + spin * dp5(zz) * area
!!$        qlm_mp_j6(hn) = qlm_mp_j6(hn) + spin * dp6(zz) * area
!!$        qlm_mp_j7(hn) = qlm_mp_j7(hn) + spin * dp7(zz) * area
!!$        qlm_mp_j8(hn) = qlm_mp_j8(hn) + spin * dp8(zz) * area
        
     end do
  end do
  
contains
  
  ! Legendre polynomials
  
  function p0 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: p0
    p0 = 1
  end function p0
  
  function p1 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: p1
    p1 = z
  end function p1
  
  function p2 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: p2
    p2 = 3*half * z**2 - half
  end function p2
  
  function p3 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: p3
    p3 = 5*half * z**3 - 3*half * z
  end function p3
  
  function p4 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: p4
    p4 = 35*eighth * z**4 - 15*fourth * z**2 + 3*eighth
  end function p4
  
  function p5 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: p5
    p5 = 63*eighth * z**5 - 35*fourth * z**3 + 15*eighth * z
  end function p5
  
  function p6 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: p6
    p6 = 231*sixteenth * z**6 - 315*sixteenth * z**4 + 105*sixteenth * z**2 &
         - 5*sixteenth
  end function p6
  
  function p7 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: p7
    p7 = 429*sixteenth * z**7 - 693*sixteenth * z**5 + 315*sixteenth * z**3 &
         - 35*sixteenth * z
  end function p7
  
  function p8 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: p8
    p8 = 6435*o128 * z**8 - 12012*o128 * z**6 + 6930*o128 * z**4 &
         - 1260*o128 * z**2 + 35*o128
  end function p8
  
  ! Derivatives of the Legendre polynomials
  
  function dp0 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: dp0
    dp0 = 0
  end function dp0
  
  function dp1 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: dp1
    dp1 = 1
  end function dp1
  
  function dp2 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: dp2
    dp2 = 3 * z
  end function dp2
  
  function dp3 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: dp3
    dp3 = 15*half * z**2 - 3*half
  end function dp3
  
  function dp4 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: dp4
    dp4 = 35*half * z**3 - 15*half*z
  end function dp4
  
  function dp5 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: dp5
    dp5 = 315*eighth * z**4 - 105*fourth * z**2 + 15*eighth
  end function dp5
  
  function dp6 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: dp6
    dp6 = 693*eighth * z**5 - 315*fourth * z**3 + 105*eighth * z
  end function dp6
  
  function dp7 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: dp7
    dp7 = 3003*sixteenth * z**6 - 3465*sixteenth * z**4 + 945*sixteenth * z**2 &
         - 35*sixteenth
  end function dp7
  
  function dp8 (z)
    CCTK_REAL, intent(in) :: z
    CCTK_REAL             :: dp8
    dp8 = 51480*o128 * z**7 - 72072*o128 * z**5 + 27720*o128 * z**3 &
         - 2520*o128 * z
  end function dp8
  
end subroutine qlm_multipoles



subroutine qlm_multipoles_normalise (CCTK_ARGUMENTS, hn)
  use cctk
  use constants
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Normalising multipole moments")
  end if
  
  ! Normalise
  
!!$  ! This is the normalisation for I_n and L_n
!!$  qlm_mp_m0(hn) = qlm_mp_m0(hn) / sqrt(4*pi/ 1)
!!$  qlm_mp_m1(hn) = qlm_mp_m1(hn) / sqrt(4*pi/ 3)
!!$  qlm_mp_m2(hn) = qlm_mp_m2(hn) / sqrt(4*pi/ 5)
!!$  qlm_mp_m3(hn) = qlm_mp_m3(hn) / sqrt(4*pi/ 7)
!!$  qlm_mp_m4(hn) = qlm_mp_m4(hn) / sqrt(4*pi/ 9)
!!$  qlm_mp_m5(hn) = qlm_mp_m5(hn) / sqrt(4*pi/11)
!!$  qlm_mp_m6(hn) = qlm_mp_m6(hn) / sqrt(4*pi/13)
!!$  qlm_mp_m7(hn) = qlm_mp_m7(hn) / sqrt(4*pi/15)
!!$  qlm_mp_m8(hn) = qlm_mp_m8(hn) / sqrt(4*pi/17)
!!$  
!!$  qlm_mp_j0(hn) = qlm_mp_j0(hn) / sqrt(4*pi/ 1)
!!$  qlm_mp_j1(hn) = qlm_mp_j1(hn) / sqrt(4*pi/ 3)
!!$  qlm_mp_j2(hn) = qlm_mp_j2(hn) / sqrt(4*pi/ 5)
!!$  qlm_mp_j3(hn) = qlm_mp_j3(hn) / sqrt(4*pi/ 7)
!!$  qlm_mp_j4(hn) = qlm_mp_j4(hn) / sqrt(4*pi/ 9)
!!$  qlm_mp_j5(hn) = qlm_mp_j5(hn) / sqrt(4*pi/11)
!!$  qlm_mp_j6(hn) = qlm_mp_j6(hn) / sqrt(4*pi/13)
!!$  qlm_mp_j7(hn) = qlm_mp_j7(hn) / sqrt(4*pi/15)
!!$  qlm_mp_j8(hn) = qlm_mp_j8(hn) / sqrt(4*pi/17)
  
  ! This is the normalisation for M_n and J_n
  qlm_mp_m0(hn) = qlm_mp_m0(hn) * qlm_mass(hn) * qlm_radius(hn)**0 / (2*pi)
  qlm_mp_m1(hn) = qlm_mp_m1(hn) * qlm_mass(hn) * qlm_radius(hn)**1 / (2*pi)
  qlm_mp_m2(hn) = qlm_mp_m2(hn) * qlm_mass(hn) * qlm_radius(hn)**2 / (2*pi)
  qlm_mp_m3(hn) = qlm_mp_m3(hn) * qlm_mass(hn) * qlm_radius(hn)**3 / (2*pi)
  qlm_mp_m4(hn) = qlm_mp_m4(hn) * qlm_mass(hn) * qlm_radius(hn)**4 / (2*pi)
  qlm_mp_m5(hn) = qlm_mp_m5(hn) * qlm_mass(hn) * qlm_radius(hn)**5 / (2*pi)
  qlm_mp_m6(hn) = qlm_mp_m6(hn) * qlm_mass(hn) * qlm_radius(hn)**6 / (2*pi)
  qlm_mp_m7(hn) = qlm_mp_m7(hn) * qlm_mass(hn) * qlm_radius(hn)**7 / (2*pi)
  qlm_mp_m8(hn) = qlm_mp_m8(hn) * qlm_mass(hn) * qlm_radius(hn)**8 / (2*pi)
  
  qlm_mp_j0(hn) = qlm_mp_j0(hn) * qlm_radius(hn)**(-1) / (8*pi)
  qlm_mp_j1(hn) = qlm_mp_j1(hn) * qlm_radius(hn)**0 / (8*pi)
  qlm_mp_j2(hn) = qlm_mp_j2(hn) * qlm_radius(hn)**1 / (8*pi)
  qlm_mp_j3(hn) = qlm_mp_j3(hn) * qlm_radius(hn)**2 / (8*pi)
  qlm_mp_j4(hn) = qlm_mp_j4(hn) * qlm_radius(hn)**3 / (8*pi)
  qlm_mp_j5(hn) = qlm_mp_j5(hn) * qlm_radius(hn)**4 / (8*pi)
  qlm_mp_j6(hn) = qlm_mp_j6(hn) * qlm_radius(hn)**5 / (8*pi)
  qlm_mp_j7(hn) = qlm_mp_j7(hn) * qlm_radius(hn)**6 / (8*pi)
  qlm_mp_j8(hn) = qlm_mp_j8(hn) * qlm_radius(hn)**7 / (8*pi)
  
end subroutine qlm_multipoles_normalise

```

qlm_analyse.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_analyse (CCTK_ARGUMENTS, hn)
  use adm_metric_simple
  use cctk
  use constants
  use qlm_derivs
  use qlm_variables
  use tensor
  use tensor2
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL, parameter :: zero=0, two=2
  integer,   parameter :: rk = kind(zero)
  
  CCTK_REAL    :: theta, phi
  CCTK_REAL    :: ll(0:3), nn(0:3)
  CCTK_COMPLEX :: mm(0:3)
  CCTK_REAL    :: ss(0:3), tt(0:3)
  CCTK_COMPLEX :: npalpha, npbeta
  CCTK_REAL    :: gg(3,3), dgg(3,3,3), kk(3,3), gg_dot(3,3)
  CCTK_REAL    :: g4(0:3,0:3), dg4(0:3,0:3,0:3)
  CCTK_REAL    :: h4(0:3,0:3), dh4(0:3,0:3,0:3)
  CCTK_REAL    :: dtg, gu(3,3), trk, dgu(3,3,3)
  CCTK_REAL    :: xx(3), ee(3,2)
  CCTK_REAL    :: xi(2), xi1(3)
  CCTK_REAL    :: qq(2,2), dtq
  CCTK_REAL    :: adm_energy, adm_mom(3), adm_amom(3)
  CCTK_REAL    :: w_energy, w_mom(3), w_amom(3,3)
  CCTK_COMPLEX :: ev
  CCTK_REAL    :: spin
  CCTK_REAL    :: npspin
  CCTK_REAL    :: wsspin
  CCTK_REAL    :: tx, ty, tz
  CCTK_REAL    :: xi1_x(3), xi1_y(3), xi1_z(3)
  CCTK_REAL    :: coordspinx, coordspiny, coordspinz
  
  CCTK_REAL    :: delta_space(2)
  
  CCTK_REAL, allocatable  :: weights(:)
  CCTK_REAL               :: sum1

  integer   :: ntheta_inner, nphi_inner

  integer   :: i_eq, j_p0, j_p2
  
  integer   :: i, j, l, m
  integer   :: a, b, c
  
  character :: msg*1000
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Calculating spin")
  end if
  
  delta_space(:) = (/ qlm_delta_theta(hn), qlm_delta_phi(hn) /)
  
  ! Equatorial circumference
  i_eq = (qlm_ntheta(hn) + 1) / 2
  
  ! Polar circumference at phi=0
  j_p0 = 1+qlm_nghostsphi(hn)
  
  ! Polar circumference at phi=pi/2
  j_p2 = 1+qlm_nghostsphi(hn) + (qlm_nphi(hn) - 2*qlm_nghostsphi(hn) - 1) / 4
  
  
  
  ! Initial values
  qlm_equatorial_circumference(hn) = 0
  qlm_polar_circumference_0(hn) = 0
  qlm_polar_circumference_pi_2(hn) = 0
  qlm_area(hn) = 0
  qlm_spin(hn) = 0
  qlm_cvspin(hn) = 0
  qlm_npspin(hn) = 0
  qlm_wsspin(hn) = 0
  qlm_coordspinx(hn) = 0
  qlm_coordspiny(hn) = 0
  qlm_coordspinz(hn) = 0
  
  qlm_adm_energy(hn) = 0
  qlm_adm_momentum_x(hn) = 0
  qlm_adm_momentum_y(hn) = 0
  qlm_adm_momentum_z(hn) = 0
  qlm_adm_angular_momentum_x(hn) = 0
  qlm_adm_angular_momentum_y(hn) = 0
  qlm_adm_angular_momentum_z(hn) = 0

  qlm_w_energy(hn) = 0
  qlm_w_momentum_x(hn) = 0
  qlm_w_momentum_y(hn) = 0
  qlm_w_momentum_z(hn) = 0
  qlm_w_angular_momentum_x(hn) = 0
  qlm_w_angular_momentum_y(hn) = 0
  qlm_w_angular_momentum_z(hn) = 0

  ! Compute weights for spherical integration (see Driscoll and Healy).
  ! These are the correct weights in a Gauss-Legendre-Senc.
  ! Also compare qlm_area with AHFinderDirect's area, they are in much
  ! better agreement than with the previous method using
  ! delta_theta*delta_phi.
  
  ntheta_inner = qlm_ntheta(hn) - 2*qlm_nghoststheta(hn)
  nphi_inner   = qlm_nphi(hn) - 2*qlm_nghostsphi(hn)
  
  allocate (weights(1+qlm_nghoststheta(hn) : qlm_ntheta(hn)-qlm_nghoststheta(hn)))
  
  do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
     theta = qlm_origin_theta(hn) + (i-1)*qlm_delta_theta(hn)
     sum1 = 0
     do l = 0, (ntheta_inner-1)/2
        sum1 = sum1 + sin((2*l+1)*theta)/(2*l+1)
     end do
     weights(i) = 8*pi * sum1 / (nphi_inner * ntheta_inner)
  end do
  
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        
        theta = qlm_origin_theta(hn) + (i-1)*qlm_delta_theta(hn)
        phi   = qlm_origin_phi(hn)   + (j-1)*qlm_delta_phi(hn)
        
        ! 2-metric on the horizon
        qq(1,1) = qlm_qtt(i,j,hn)
        qq(1,2) = qlm_qtp(i,j,hn)
        qq(2,2) = qlm_qpp(i,j,hn)
        qq(2,1) = qq(1,2)
        call calc_2det (qq, dtq)
        
        ll(0) = qlm_l0(i,j,hn)
        ll(1) = qlm_l1(i,j,hn)
        ll(2) = qlm_l2(i,j,hn)
        ll(3) = qlm_l3(i,j,hn)
        
        nn(0) = qlm_n0(i,j,hn)
        nn(1) = qlm_n1(i,j,hn)
        nn(2) = qlm_n2(i,j,hn)
        nn(3) = qlm_n3(i,j,hn)
        
        mm(0) = qlm_m0(i,j,hn)
        mm(1) = qlm_m1(i,j,hn)
        mm(2) = qlm_m2(i,j,hn)
        mm(3) = qlm_m3(i,j,hn)
        
        tt = (ll + nn) / sqrt(two)
        ss = (ll - nn) / sqrt(two)
        
        npalpha = qlm_npalpha(i,j,hn)
        npbeta  = qlm_npbeta(i,j,hn)
        
        gg(1,1) = qlm_gxx(i,j)
        gg(1,2) = qlm_gxy(i,j)
        gg(1,3) = qlm_gxz(i,j)
        gg(2,2) = qlm_gyy(i,j)
        gg(2,3) = qlm_gyz(i,j)
        gg(3,3) = qlm_gzz(i,j)
        gg(2,1) = gg(1,2)
        gg(3,1) = gg(1,3)
        gg(3,2) = gg(2,3)
        
        dgg(1,1,1) = qlm_dgxxx(i,j)
        dgg(1,2,1) = qlm_dgxyx(i,j)
        dgg(1,3,1) = qlm_dgxzx(i,j)
        dgg(2,2,1) = qlm_dgyyx(i,j)
        dgg(2,3,1) = qlm_dgyzx(i,j)
        dgg(3,3,1) = qlm_dgzzx(i,j)
        dgg(2,1,1) = dgg(1,2,1)
        dgg(3,1,1) = dgg(1,3,1)
        dgg(3,2,1) = dgg(2,3,1)
        dgg(1,1,2) = qlm_dgxxy(i,j)
        dgg(1,2,2) = qlm_dgxyy(i,j)
        dgg(1,3,2) = qlm_dgxzy(i,j)
        dgg(2,2,2) = qlm_dgyyy(i,j)
        dgg(2,3,2) = qlm_dgyzy(i,j)
        dgg(3,3,2) = qlm_dgzzy(i,j)
        dgg(2,1,2) = dgg(1,2,2)
        dgg(3,1,2) = dgg(1,3,2)
        dgg(3,2,2) = dgg(2,3,2)
        dgg(1,1,3) = qlm_dgxxz(i,j)
        dgg(1,2,3) = qlm_dgxyz(i,j)
        dgg(1,3,3) = qlm_dgxzz(i,j)
        dgg(2,2,3) = qlm_dgyyz(i,j)
        dgg(2,3,3) = qlm_dgyzz(i,j)
        dgg(3,3,3) = qlm_dgzzz(i,j)
        dgg(2,1,3) = dgg(1,2,3)
        dgg(3,1,3) = dgg(1,3,3)
        dgg(3,2,3) = dgg(2,3,3)
        
        kk(1,1) = qlm_kxx(i,j)
        kk(1,2) = qlm_kxy(i,j)
        kk(1,3) = qlm_kxz(i,j)
        kk(2,2) = qlm_kyy(i,j)
        kk(2,3) = qlm_kyz(i,j)
        kk(3,3) = qlm_kzz(i,j)
        kk(2,1) = kk(1,2)
        kk(3,1) = kk(1,3)
        kk(3,2) = kk(2,3)
        
        
        
        call calc_det (gg, dtg)
        call calc_inv (gg, dtg, gu)
        call calc_trace (gu, kk, trk)
        
        ! Calculate time derivatives
        call calc_3metricdot_simple (kk, gg_dot)
        
        ! Calculate 4-metric
        call calc_4metricderivs_simple (gg, dgg, gg_dot, g4,dg4)

        ! Calculate derivative of 4-metric inverse
        call calc_invderiv (gu, dgg, dgu)
        
        ! "Perturbative" 4-metric
        h4 = g4 - eta4
        dh4 = dg4
        
        xx(1) = qlm_x(i,j,hn)
        xx(2) = qlm_y(i,j,hn)
        xx(3) = qlm_z(i,j,hn)
        
        ee(1,1:2) = deriv (qlm_x(:,:,hn), i, j, delta_space)
        ee(2,1:2) = deriv (qlm_y(:,:,hn), i, j, delta_space)
        ee(3,1:2) = deriv (qlm_z(:,:,hn), i, j, delta_space)
        
        xi(1) = qlm_xi_t(i,j,hn)
        xi(2) = qlm_xi_p(i,j,hn)
        
        if (i == i_eq) then
           qlm_equatorial_circumference(hn) = qlm_equatorial_circumference(hn) &
                + sqrt(qq(2,2)) * qlm_delta_phi(hn)
        end if
        
        if (j == j_p0) then
           qlm_polar_circumference_0(hn) = qlm_polar_circumference_0(hn) &
                + sqrt(qq(1,1)) * qlm_delta_theta(hn)
        end if
        
        if (j == j_p2) then
           qlm_polar_circumference_pi_2(hn) = qlm_polar_circumference_pi_2(hn) &
                + sqrt(qq(1,1)) * qlm_delta_theta(hn)
        end if
        
        qlm_area(hn) = qlm_area(hn) &
             + sqrt(dtq) * weights(i)
        
        ! s^i: outward spacelike normal
        ! K_ij: extrinsic curvature
        ! phi^i: rotational Killing vector
        
        do a=1,3
           xi1(a) = 0
           do b=1,2
              xi1(a) = xi1(a) + ee(a,b) * xi(b)
           end do
        end do
        
        ! phi^i omega_i = - phi^i s^j K_ij
        
        spin = 0
        do a=1,3
           do b=1,3
              spin = spin + xi1(a) * ss(b) * kk(a,b)
           end do
        end do
        qlm_spin_density(i,j) = spin
        
        ! phi^i omega_i = (alpha + ~beta) phi^i m_i + complex conjugate
        npspin = 0
        do a=1,3
           do b=1,3
              npspin = npspin + 2 * real((npalpha + conjg(npbeta)) * xi1(a) * gg(a,b) * mm(b))
           end do
        end do
        
        ! phi^i omega_i = 1/2 f Im Psi_2
        ! (or is it   phi^i omega_i = - f Im Psi_2   ?)
        wsspin = - qlm_inv_z(i,j,hn) * aimag(qlm_psi2(i,j,hn))
        
        ! x = sin theta cos phi
        ! y = sin theta sin phi
        ! z = cos theta
        ! xi_x = (0,-z,y)
        ! xi_y = (z,0,-x)
        ! xi_z = (-y,x,0)
        tx = qlm_x(i,j,hn) - qlm_origin_x(hn)
        ty = qlm_y(i,j,hn) - qlm_origin_y(hn)
        tz = qlm_z(i,j,hn) - qlm_origin_z(hn)
        xi1_x(:) = (/ zero, -tz, ty /)
        xi1_y(:) = (/ tz, zero, -tx /)
        xi1_z(:) = (/ -ty, tx, zero /)
        coordspinx = 0
        coordspiny = 0
        coordspinz = 0
        do a=1,3
           do b=1,3
              coordspinx = coordspinx + xi1_x(a) * ss(b) * kk(a,b)
              coordspiny = coordspiny + xi1_y(a) * ss(b) * kk(a,b)
              coordspinz = coordspinz + xi1_z(a) * ss(b) * kk(a,b)
           end do
        end do
        
        xi1_x(:) = (/ 1, 0, 0 /)
        xi1_y(:) = (/ 0, 1, 0 /)
        xi1_z(:) = (/ 0, 0, 1 /)
        
        qlm_spin(hn) = qlm_spin(hn) &
             + spin * sqrt(dtq) * weights(i)

        qlm_npspin(hn) = qlm_npspin(hn) &
             + npspin * sqrt(dtq) * weights(i)
        
        qlm_wsspin(hn) = qlm_wsspin(hn) &
             + wsspin * sqrt(dtq) * weights(i)
        
        qlm_coordspinx(hn) = qlm_coordspinx(hn) &
             + coordspinx * sqrt(dtq) * weights(i)
        qlm_coordspiny(hn) = qlm_coordspiny(hn) &
             + coordspiny * sqrt(dtq) * weights(i)
        qlm_coordspinz(hn) = qlm_coordspinz(hn) &
             + coordspinz * sqrt(dtq) * weights(i)
        
        ! ADM quantities
        ! Alcubierre, Appendix A, p. 402 ff, eqns. (A.5) - (A.7):
        
        ! ADM energy
        ! E_adm = (1/16 pi) int_S(r) [delta^jk h_ik,j - (trace(h)),i] n^i r^2 dOmega
        adm_energy = 0
        do a=1,3
           do b=1,3
              do c=1,3
                 adm_energy = adm_energy + (delta3(a,b) * dh4(a,c,b) &
             & - gu(a,b) * dh4(a,b,c) - h4(a,b) * dgu(a,b,c) ) * ss(c)
              end do
           end do
        end do
        qlm_adm_energy(hn) = qlm_adm_energy(hn) &
             & + adm_energy / (16*pi) &
             &   * sqrt(dtq) * qlm_delta_theta(hn) * qlm_delta_phi(hn)
        
        ! ADM momentum
        ! P_adm^i = (1/8 pi) int_S(r) [K^i_j - K delta^i_j] n^j r^2 dOmega
        do a=1,3
           adm_mom(a) = 0
           do b=1,3
              do c=1,3
                 adm_mom(a) = adm_mom(a) &
             &        + gu(a,c) * kk(c,b) * ss(b) 
              end do
              adm_mom(a) = adm_mom(a) &
                   + delta3(a,b) * trk * ss(b) 
           end do
        end do
        qlm_adm_momentum_x(hn) = qlm_adm_momentum_x(hn) &
             & + adm_mom(1) / (8*pi) &
             &   * sqrt(dtq) * qlm_delta_theta(hn) * qlm_delta_phi(hn)
        qlm_adm_momentum_y(hn) = qlm_adm_momentum_y(hn) &
             & + adm_mom(2) / (8*pi) &
             &   * sqrt(dtq) * qlm_delta_theta(hn) * qlm_delta_phi(hn)
        qlm_adm_momentum_z(hn) = qlm_adm_momentum_z(hn) &
             & + adm_mom(3) / (8*pi) &
             &   * sqrt(dtq) * qlm_delta_theta(hn) * qlm_delta_phi(hn)
        
        ! ADM angular momentum
        ! J_adm^i = (1/8 pi) int_S(r)
        !   epsilon^ijk x_j (K_kl - delta_kl K) * n^l dS 
        do a=1,3
           adm_amom(a) = 0
           do b=1,3
              do c=1,3
                 do l=1,3
                    do m=1,3
                       adm_amom(a) = adm_amom(a)  &
                &         + epsilon3(a,b,c) * xx(b) * gu(c,m) * kk(m,l) * ss(l)
                    end do
                    adm_amom(a) = adm_amom(a)  &
                &    - epsilon3(a,b,c) * xx(b) *  delta3(c,l) * trk * ss(l)
                 end do
              end do
           end do
        end do
        qlm_adm_angular_momentum_x(hn) = qlm_adm_angular_momentum_x(hn) &
             & + adm_amom(1) / (8*pi) &
             &   * sqrt(dtq) * qlm_delta_theta(hn) * qlm_delta_phi(hn)
        qlm_adm_angular_momentum_y(hn) = qlm_adm_angular_momentum_y(hn) &
             & + adm_amom(2) / (8*pi) &
             &   * sqrt(dtq) * qlm_delta_theta(hn) * qlm_delta_phi(hn)
        qlm_adm_angular_momentum_z(hn) = qlm_adm_angular_momentum_z(hn) &
             & + adm_amom(3) / (8*pi) &
             &   * sqrt(dtq) * qlm_delta_theta(hn) * qlm_delta_phi(hn)

        ! Weinberg pseudotensor quantities
        ! Weinberg, chapter 7.6, pp. 165 ff, eqns. (7.6.22) - (7.6.24):
        
        ! Weinberg energy
        ! E_w = (-1/16 pi) int_S(r) [h_jj,i - hij,j] n_i r^2 dOmega
        w_energy = 0
        do a=1,3
           do b=1,3
              w_energy = w_energy + (dh4(b,b,a) - dh4(a,b,b)) * ss(a)
           end do
        end do
        qlm_w_energy(hn) = qlm_w_energy(hn) &
             & + w_energy / (-16*pi) &
             &   * sqrt(dtq) * weights(i)
        
        ! Weinberg momentum
        ! P_ll^j = (-1/16 pi) int_S(r)
        !    [- h_kk,0 delta_ij + h_k0,k delta_ij
        !     - h_j0,i + h_ij,0                  ] n_i r^2 dOmega
        ! 
        ! P_ll^j = (1/8 pi) int_S(r) [K_ij - K delta_ij] n_i r^2 dOmega
        do a=1,3
           w_mom(a) = 0
           do b=1,3
              w_mom(a) = w_mom(a) &
                   + (- dh4(b,b,0) + dh4(b,0,b)) * ss(a) &
                   + (- dh4(a,0,b) + dh4(b,a,0)) * ss(b)
           end do
        end do
        qlm_w_momentum_x(hn) = qlm_w_momentum_x(hn) &
             & + w_mom(1) / (-16*pi) &
             &   * sqrt(dtq) * weights(i)
        qlm_w_momentum_y(hn) = qlm_w_momentum_y(hn) &
             & + w_mom(2) / (-16*pi) &
             &   * sqrt(dtq) * weights(i)
        qlm_w_momentum_z(hn) = qlm_w_momentum_z(hn) &
             & + w_mom(3) / (-16*pi) &
             &   * sqrt(dtq) * weights(i)
        
        ! Weinberg angular momentum
        ! J_ll^jk = (-1/16 pi) int_S(r)
        !    [- x_j h_0k,i + x_k h_0j,i
        !     + x_j h_ki,0 - x_k h_ji,0
        !     + h_0k delta_ij - h_0j delta_ik] n_i r^2 dOmega
        do a=1,3
           do b=1,3
              w_amom(a,b) = 0
              do c=1,3
                 w_amom(a,b) = w_amom(a,b) + ss(c) * ( &
                      + (- xx(a) * dh4(0,b,c) + xx(b) * dh4(0,a,c)) &
                      + (+ xx(a) * dh4(b,c,0) - xx(b) * dh4(a,c,0)) &
                      + (h4(0,b) * delta4(c,a) - h4(0,a) * delta4(c,b)))
              end do
           end do
        end do
        qlm_w_angular_momentum_x(hn) = qlm_w_angular_momentum_x(hn) &
             & + w_amom(2,3) / (-16*pi) &
             &   * sqrt(dtq) * weights(i)
        qlm_w_angular_momentum_y(hn) = qlm_w_angular_momentum_y(hn) &
             & + w_amom(3,1) / (-16*pi) &
             &   * sqrt(dtq) * weights(i)
        qlm_w_angular_momentum_z(hn) = qlm_w_angular_momentum_z(hn) &
             & + w_amom(1,2) / (-16*pi) &
             &   * sqrt(dtq) * weights(i)
        
     end do
  end do
  
  deallocate(weights)
  
  qlm_polar_circumference_0(hn) = qlm_polar_circumference_0(hn) * 2
  qlm_polar_circumference_pi_2(hn) = qlm_polar_circumference_pi_2(hn) * 2
  
  ! A = 4 pi R^2
  ! R = 2 M
  qlm_radius(hn) = sqrt(qlm_area(hn) / (4*pi))
  qlm_irreducible_mass(hn) = qlm_radius(hn) / 2
  
  qlm_spin(hn) = qlm_spin(hn) / (8*pi)
  qlm_mass(hn) = 1/(2*qlm_radius(hn)) * sqrt(qlm_radius(hn)**4 + 4*qlm_spin(hn)**2)
  qlm_cvspin(hn) = qlm_cvspin(hn) / (8*pi)
  qlm_npspin(hn) = qlm_npspin(hn) / (-8*pi)
  qlm_wsspin(hn) = qlm_wsspin(hn) / (-4*pi)
  qlm_coordspinx(hn) = qlm_coordspinx(hn) / (8*pi)
  qlm_coordspiny(hn) = qlm_coordspiny(hn) / (8*pi)
  qlm_coordspinz(hn) = qlm_coordspinz(hn) / (8*pi)
  
  ! The event horizon is at r = M + sqrt (M^2 - a^2)
  ! with x^2 + y^2 + z^2 = rho^2 = r^2 + a^2 (1 - z^2 / r^2)
  
  call guess_mass_spin &
       (qlm_area(hn), qlm_equatorial_circumference(hn), qlm_mass_guess(hn), qlm_spin_guess(hn))
  
  
  
  if (verbose/=0) then
     
     write (msg, '("Geometric quantities for surface ",i4,":")') hn-1
     call CCTK_INFO (msg)
     write (msg, '("   Area A:                       ",g16.6)') qlm_area(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Irreducible mass M = R/2:     ",g16.6)') qlm_irreducible_mass(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Areal radius R = sqrt(A/4pi): ",g16.6)') qlm_radius(hn)
     call CCTK_INFO (msg)
     
     write (msg, '("Coordinate-dependent quantities for surface ",i4,":")') hn-1
     call CCTK_INFO (msg)
     write (msg, '("   Equatorial circumference:        ",g16.6)') &
          qlm_equatorial_circumference(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Polar circumference at phi=0:    ",g16.6)') &
          qlm_polar_circumference_0(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Polar circumference at phi=pi/2: ",g16.6)') &
          qlm_polar_circumference_pi_2(hn)
     call CCTK_INFO (msg)
     if (qlm_spin_guess(hn) >= 0) then
        write (msg, '("   Spin guess J from distortion:    ",g16.6)') &
             qlm_spin_guess(hn)
        call CCTK_INFO (msg)
     else
        call CCTK_INFO ("   No valid spin guess from distortion.")
        call CCTK_INFO ("   (Spin guess is imaginary.)")
        write (msg, '("   Magnitude of invalid spin guess: ",g16.6)') &
             abs(qlm_spin_guess(hn))
        call CCTK_INFO (msg)
     end if
     write (msg, '("   Mass guess M from distortion:    ",g16.6)') &
          qlm_mass_guess(hn)
     call CCTK_INFO (msg)
     
     write (msg, '("Isolated Horizon quantities for surface ",i4,":")') hn-1
     call CCTK_INFO (msg)
     ev = cmplx(qlm_killing_eigenvalue_re(hn), qlm_killing_eigenvalue_im(hn),rk)
     write (msg, '("   Killing vector field eigenvalue norm:   ",g14.6)') abs(ev)
     call CCTK_INFO (msg)
     write (msg, '("   Spin J:                                 ",g14.6)') qlm_spin(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Kerr spin parameter a = J/M:            ",g14.6)') qlm_spin(hn) / qlm_mass(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Dimensionless spin parameter a = J/M^2: ",g14.6)') qlm_spin(hn) / qlm_mass(hn)**2
     call CCTK_INFO (msg)
     write (msg, '("   Spin J from NP:                         ",g14.6)') qlm_npspin(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Spin J from phi-coordinate-vector:      ",g14.6)') qlm_cvspin(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Mass M:                                 ",g14.6)') qlm_mass(hn)
     call CCTK_INFO (msg)
     
     write (msg, '("Global quantities for surface ",i4,":")') hn-1
     call CCTK_INFO (msg)
     write (msg, '("   ADM energy:             ",g16.6)') qlm_adm_energy(hn)
     call CCTK_INFO (msg)
     write (msg, '("   ADM momentum x:         ",g16.6)') qlm_adm_momentum_x(hn)
     call CCTK_INFO (msg)
     write (msg, '("   ADM momentum y:         ",g16.6)') qlm_adm_momentum_y(hn)
     call CCTK_INFO (msg)
     write (msg, '("   ADM momentum z:         ",g16.6)') qlm_adm_momentum_z(hn)
     call CCTK_INFO (msg)
     write (msg, '("   ADM angular momentum x: ",g16.6)') qlm_adm_angular_momentum_x(hn)
     call CCTK_INFO (msg)
     write (msg, '("   ADM angular momentum y: ",g16.6)') qlm_adm_angular_momentum_y(hn)
     call CCTK_INFO (msg)
     write (msg, '("   ADM angular momentum z: ",g16.6)') qlm_adm_angular_momentum_z(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Weinberg energy:             ",g16.6)') qlm_w_energy(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Weinberg momentum x:         ",g16.6)') qlm_w_momentum_x(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Weinberg momentum y:         ",g16.6)') qlm_w_momentum_y(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Weinberg momentum z:         ",g16.6)') qlm_w_momentum_z(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Weinberg angular momentum x: ",g16.6)') qlm_w_angular_momentum_x(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Weinberg angular momentum y: ",g16.6)') qlm_w_angular_momentum_y(hn)
     call CCTK_INFO (msg)
     write (msg, '("   Weinberg angular momentum z: ",g16.6)') qlm_w_angular_momentum_z(hn)
     call CCTK_INFO (msg)
     
  end if
  
contains
  
  subroutine guess_mass_spin (area, circumference, mass, spin)
    CCTK_REAL, intent(in)  :: area, circumference
    CCTK_REAL, intent(out) :: mass, spin
    CCTK_REAL :: radius, amom2, amom
    
    ! equatorial circumference L, area A
    
    ! L = 2 pi (r^2 + a^2) / r
    ! A = 4 pi (r^2 + a^2)
    ! r = M + sqrt (M^2 - a^2)
    
    ! r = A / (2 L)
    ! a^2 = A / (4 pi) - r^2   ("spin" a = J/M = specific angular momentum)
    ! M = (r^2 + a^2) / (2 r)
    
    ! J = a M   (angular momentum)
    
    radius = area / (2*circumference)
    amom2 = area / (4*pi) - radius**2
    amom = sign(sqrt(abs(amom2)), amom2)
    mass = (radius**2 + amom2) / (2*radius)
    spin = amom * mass
    
    ! equatorial circumference L, area A
    ! mass M, areal radius R, spin a = J/M^2
    
    ! A = 4 pi R^2
    ! L = 4 pi M
    
    ! a^2 = (R/M)^2 - 1/4 (R/M)^4
    ! J = a M^2
    
  end subroutine guess_mass_spin
  
end subroutine qlm_analyse

```

qlm_import_surface.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_import_surface (CCTK_ARGUMENTS, hn)
  use cctk
  use qlm_boundary
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  integer   :: i, j, sn, sname_length
  character :: msg*1000, sname*200
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Importing surface shape")
  end if
  
  if ((surface_index(hn) < 0 .or. surface_index(hn) >= nsurfaces) .and. &
      CCTK_EQUALS(surface_name(hn), "")) then
     call CCTK_WARN (0, "Illegal spherical surface index specified")
  end if
  
  sn = sf_IdFromName(surface_index(hn), surface_name(hn)) + 1
  
  if (verbose/=0 .or. veryverbose/=0) then
     call CCTK_FortranString(sname_length, surface_name(hn), sname)
     ! no error checking since FortranString's truncation is sufficient
     write (msg, '("Importing from spherical surface ",i4," ",a)') &
           sn - 1, TRIM(sname)
     call CCTK_INFO (msg)
  end if
  
  
  if (qlm_calc_error(hn) == 0 .and. cctk_iteration > qlm_iteration(hn)) then
     
     ! Cycle time levels
     qlm_have_valid_data_p_p(hn)     = qlm_have_valid_data_p(hn)
     qlm_have_valid_data_p  (hn)     = qlm_have_valid_data  (hn)
     qlm_have_killing_vector_p_p(hn) = qlm_have_killing_vector_p(hn)
     qlm_have_killing_vector_p  (hn) = qlm_have_killing_vector  (hn)
     qlm_iteration(hn)               = cctk_iteration
     
     qlm_time_p_p(hn) = qlm_time_p(hn)
     qlm_time_p  (hn) = qlm_time  (hn)
     qlm_radius_p_p(hn) = qlm_radius_p(hn)
     qlm_radius_p  (hn) = qlm_radius  (hn)
     
     qlm_origin_x_p_p(hn) = qlm_origin_x_p(hn)
     qlm_origin_x_p  (hn) = qlm_origin_x  (hn)
     qlm_origin_y_p_p(hn) = qlm_origin_y_p(hn)
     qlm_origin_y_p  (hn) = qlm_origin_y  (hn)
     qlm_origin_z_p_p(hn) = qlm_origin_z_p(hn)
     qlm_origin_z_p  (hn) = qlm_origin_z  (hn)
     
     qlm_shape_p_p(:,:,hn) = qlm_shape_p(:,:,hn)
     qlm_shape_p  (:,:,hn) = qlm_shape  (:,:,hn)
     
  end if
  
  
  
  ! Check for valid horizon data
  if (sf_valid(sn) <= 0) then
     if (verbose/=0) then
        call CCTK_INFO ("No valid horizon data found")
     end if
     qlm_calc_error(hn) = 1
     qlm_have_valid_data(hn) = 0
     qlm_have_killing_vector(hn) = 0
     return
  end if
  
  
  
  ! Import surface description
  qlm_calc_error(hn) = 0
  qlm_have_valid_data(hn) = 0
  qlm_have_killing_vector(hn) = 1
  
  if (qlm_have_valid_data_p(hn) == 0) then
     qlm_timederiv_order(hn) = 0
  else if (qlm_have_valid_data_p_p(hn) == 0) then
     qlm_timederiv_order(hn) = 1
  else
     qlm_timederiv_order(hn) = 2
  end if
  
  qlm_time(hn) = cctk_time
  
#warning "TODO: Ensure that the surface parameters don't change"
  qlm_nghoststheta(hn) = sf_nghoststheta(sn)
  qlm_nghostsphi  (hn) = sf_nghostsphi(sn)
  qlm_ntheta      (hn) = sf_ntheta(sn)
  qlm_nphi        (hn) = sf_nphi(sn)
  
  qlm_origin_x    (hn) = sf_origin_x(sn)
  qlm_origin_y    (hn) = sf_origin_y(sn)
  qlm_origin_z    (hn) = sf_origin_z(sn)
  qlm_origin_theta(hn) = sf_origin_theta(sn)
  qlm_origin_phi  (hn) = sf_origin_phi(sn)
  qlm_delta_theta (hn) = sf_delta_theta(sn)
  qlm_delta_phi   (hn) = sf_delta_phi(sn)
  
  if (veryverbose /= 0) then
     write (msg, '("calc error      : ",i6)') qlm_calc_error(hn)
     call CCTK_INFO (msg)
     write (msg, '("time deriv order: ",i6)') qlm_timederiv_order(hn)
     call CCTK_INFO (msg)
     write (msg, '("time            : ",g16.6)') qlm_time(hn)
     call CCTK_INFO (msg)
     write (msg, '("nghosts         : ",2i6)') qlm_nghoststheta(hn), qlm_nghostsphi(hn)
     call CCTK_INFO (msg)
     write (msg, '("n               : ",2i6)') qlm_ntheta(hn), qlm_nphi(hn)
     call CCTK_INFO (msg)
     write (msg, '("origin          : ",3g16.6)') &
          qlm_origin_x(hn), qlm_origin_y(hn), qlm_origin_z(hn)
     call CCTK_INFO (msg)
     write (msg, '("origin          : ",2g16.6)') &
          qlm_origin_theta(hn), qlm_origin_phi(hn)
     call CCTK_INFO (msg)
     write (msg, '("delta           : ",2g16.6)') &
          qlm_delta_theta(hn), qlm_delta_phi(hn)
     call CCTK_INFO (msg)
  end if
  
  if (qlm_ntheta(hn) > maxntheta .or. qlm_nphi(hn) > maxnphi) then
     call CCTK_WARN (0, "Surface is too large")
  end if
  
  if (qlm_nghoststheta(hn)<1 .or. qlm_nghostsphi(hn)<1) then
     call CCTK_WARN (0, "Not enough ghost zones for the horizon surface -- need at least 1")
  end if
  
  
  ! Import the surface
  ! Calculate the coordinates
  do j = 1, qlm_nphi(hn)
     do i = 1, qlm_ntheta(hn)
        qlm_shape(i,j,hn) = sf_radius(i,j,sn)
     end do
  end do
  
  
  
  if (mod(int(qlm_ntheta(hn) - 2*qlm_nghoststheta(hn)),2) /= 1) then
     ! We need a grid point on the equator
     call CCTK_WARN (0, "The number of interior grid points in theta direction must be odd")
  end if
  
  if (mod(int(qlm_nphi(hn) - 2*qlm_nghostsphi(hn)),4) /= 0) then
     ! We need grid points on the four major meridians
     call CCTK_WARN (0, "The number of interior grid points in phi direction must be a multiple of four")
  end if
  
end subroutine qlm_import_surface

```

qlm_newman_penrose.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_calc_newman_penrose (CCTK_ARGUMENTS, hn)
  use adm_metric
  use cctk
  use classify
  use constants
  use qlm_boundary
  use qlm_derivs
  use qlm_variables
  use ricci4
  use tensor
  use tensor4
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL, parameter :: zero=0, one=1, two=2, half=1/two
  CCTK_REAL    :: ll(0:3), nn(0:3)
  CCTK_COMPLEX :: mm(0:3)
  CCTK_REAL    :: nabla_ll(0:3,0:3), nabla_nn(0:3,0:3)
  CCTK_COMPLEX :: nabla_mm(0:3,0:3)
  
  CCTK_REAL    :: t0, t1, t2
  logical      :: ce0, ce1, ce2
  CCTK_REAL    :: delta_space(2)
  
  integer      :: i, j
  integer      :: a, b
  CCTK_REAL    :: theta, phi
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Calculating Newman-Penrose quantities")
  end if
  
  t0 = qlm_time(hn)
  t1 = qlm_time_p(hn)
  t2 = qlm_time_p_p(hn)
  
  ce0 = qlm_have_valid_data(hn) == 0
  ce1 = qlm_have_valid_data_p(hn) == 0
  ce2 = qlm_have_valid_data_p_p(hn) == 0
  
  delta_space(:) = (/ qlm_delta_theta(hn), qlm_delta_phi(hn) /)
  
  if (qlm_nghoststheta(hn)<2 .or. qlm_nghostsphi(hn)<2) call CCTK_WARN (0, "internal error")

  ! Calculate the coordinates
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        theta = qlm_origin_theta(hn) + (i-1)*qlm_delta_theta(hn)
        phi   = qlm_origin_phi(hn)   + (j-1)*qlm_delta_phi(hn)
        
        ! Get the stuff from the arrays
        ll(0) = qlm_l0(i,j,hn)
        ll(1) = qlm_l1(i,j,hn)
        ll(2) = qlm_l2(i,j,hn)
        ll(3) = qlm_l3(i,j,hn)
        
        nn(0) = qlm_n0(i,j,hn)
        nn(1) = qlm_n1(i,j,hn)
        nn(2) = qlm_n2(i,j,hn)
        nn(3) = qlm_n3(i,j,hn)
        
        mm(0) = qlm_m0(i,j,hn)
        mm(1) = qlm_m1(i,j,hn)
        mm(2) = qlm_m2(i,j,hn)
        mm(3) = qlm_m3(i,j,hn)
        
        nabla_ll(:,:) = qlm_tetrad_derivs(i,j)%nabla_ll(:,:)
        nabla_nn(:,:) = qlm_tetrad_derivs(i,j)%nabla_nn(:,:)
        nabla_mm(:,:) = qlm_tetrad_derivs(i,j)%nabla_mm(:,:)
        
        
        
        ! kappa   = - m^a  l^b D_b l_a
        ! tau     = - m^a  n^b D_b l_a
        ! sigma   = - m^a  m^b D_b l_a
        ! rho     = - m^a ~m^b D_b l_a   [ ~m = congj(m) ]
        qlm_npkappa  (i,j,hn) = 0
        qlm_nptau    (i,j,hn) = 0
        qlm_npsigma  (i,j,hn) = 0
        qlm_nprho    (i,j,hn) = 0
        ! epsilon = - 1/2 ( n^a  l^b D_b l_a - ~m^a  l^b D_b m_a )
        ! gamma   = - 1/2 ( n^a  n^b D_b l_a - ~m^a  n^b D_b m_a )
        ! beta    = - 1/2 ( n^a  m^b D_b l_a - ~m^a  m^b D_b m_a )
        ! alpha   = - 1/2 ( n^a ~m^b D_b l_a - ~m^a ~m^b D_b m_a )
        qlm_npepsilon(i,j,hn) = 0
        qlm_npgamma  (i,j,hn) = 0
        qlm_npbeta   (i,j,hn) = 0
        qlm_npalpha  (i,j,hn) = 0
        ! pi      = ~m^a  l^b D_b n_a
        ! nu      = ~m^a  n^b D_b n_a
        ! mu      = ~m^a  m^b D_b n_a
        ! lambda  = ~m^a ~m^b D_b n_a
        qlm_nppi     (i,j,hn) = 0
        qlm_npnu     (i,j,hn) = 0
        qlm_npmu     (i,j,hn) = 0
        qlm_nplambda (i,j,hn) = 0
        
!!$        qlm_lie_l_npsigma(i,j,hn) = 0
!!$        qlm_lie_n_npsigma(i,j,hn) = 0
        
!!$        ! Theta is the expansion
!!$        ! Theta_(l) is (- 2 Re rho)
!!$        ! Theta_(n) is (+ 2 Re mu)
!!$        ! Theta_(T) is [Theta_(l) + Theta_(n)] / sqrt(2)
!!$        ! Theta_(S) is [Theta_(l) - Theta_(n)] / sqrt(2)
        
!!$        qlm_lie_l_theta_l(i,j,hn) = 0
!!$        qlm_lie_l_theta_n(i,j,hn) = 0
!!$        qlm_lie_n_theta_l(i,j,hn) = 0
!!$        qlm_lie_n_theta_n(i,j,hn) = 0
        
        do a=0,3
           do b=0,3
              qlm_npkappa  (i,j,hn) = qlm_npkappa  (i,j,hn) - mm(a) *       ll(b)  * nabla_ll(a,b)
              qlm_nptau    (i,j,hn) = qlm_nptau    (i,j,hn) - mm(a) *       nn(b)  * nabla_ll(a,b)
              qlm_npsigma  (i,j,hn) = qlm_npsigma  (i,j,hn) - mm(a) *       mm(b)  * nabla_ll(a,b)
              qlm_nprho    (i,j,hn) = qlm_nprho    (i,j,hn) - mm(a) * conjg(mm(b)) * nabla_ll(a,b)
              qlm_npepsilon(i,j,hn) = qlm_npepsilon(i,j,hn) - half * (nn(a) *       ll(b)  * nabla_ll(a,b) - conjg(mm(a)) *       ll(b)  * nabla_mm(a,b))
              qlm_npgamma  (i,j,hn) = qlm_npgamma  (i,j,hn) - half * (nn(a) *       nn(b)  * nabla_ll(a,b) - conjg(mm(a)) *       nn(b)  * nabla_mm(a,b))
              qlm_npbeta   (i,j,hn) = qlm_npbeta   (i,j,hn) - half * (nn(a) *       mm(b)  * nabla_ll(a,b) - conjg(mm(a)) *       mm(b)  * nabla_mm(a,b))
              qlm_npalpha  (i,j,hn) = qlm_npalpha  (i,j,hn) - half * (nn(a) * conjg(mm(b)) * nabla_ll(a,b) - conjg(mm(a)) * conjg(mm(b)) * nabla_mm(a,b))
              qlm_nppi     (i,j,hn) = qlm_nppi     (i,j,hn) + conjg(mm(a)) *       ll(b)  * nabla_nn(a,b)
              qlm_npnu     (i,j,hn) = qlm_npnu     (i,j,hn) + conjg(mm(a)) *       nn(b)  * nabla_nn(a,b)
              qlm_npmu     (i,j,hn) = qlm_npmu     (i,j,hn) + conjg(mm(a)) *       mm(b)  * nabla_nn(a,b)
              qlm_nplambda (i,j,hn) = qlm_nplambda (i,j,hn) + conjg(mm(a)) * conjg(mm(b)) * nabla_nn(a,b)
              
           end do
        end do
        
     end do
  end do
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_npkappa  (:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_nptau    (:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_npsigma  (:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_nprho    (:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_npepsilon(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_npgamma  (:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_npbeta   (:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_npalpha  (:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_nppi     (:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_npnu     (:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_npmu     (:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_nplambda (:,:,hn), +1)
  
end subroutine qlm_calc_newman_penrose

```

qlm_killing_test.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_killing_test (CCTK_ARGUMENTS, hn)
  use cctk
  use qlm_boundary
  use qlm_derivs
  use qlm_variables
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL :: qq(2,2), dqq(2,2,2)
  CCTK_REAL :: xi(2), dxi(2,2)
  CCTK_REAL :: lqq(2,2)
  
  CCTK_REAL    :: delta_space(2)
  
  integer   :: i,j
  integer   :: a, b, c
  CCTK_REAL :: theta, phi
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Testing Killing vector field")
  end if
  
  delta_space(:) = (/ qlm_delta_theta(hn), qlm_delta_phi(hn) /)
  
  ! Calculate the coordinates
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        theta = qlm_origin_theta(hn) + (i-1)*qlm_delta_theta(hn)
        phi   = qlm_origin_phi(hn)   + (j-1)*qlm_delta_phi(hn)
        
        ! 2-metric on the horizon
        qq(1,1) = qlm_qtt(i,j,hn)
        qq(1,2) = qlm_qtp(i,j,hn)
        qq(2,2) = qlm_qpp(i,j,hn)
        qq(2,1) = qq(1,2)
        
        dqq(1,1,1) = qlm_dqttt(i,j)
        dqq(1,2,1) = qlm_dqtpt(i,j)
        dqq(2,2,1) = qlm_dqppt(i,j)
        dqq(1,1,2) = qlm_dqttp(i,j)
        dqq(1,2,2) = qlm_dqtpp(i,j)
        dqq(2,2,2) = qlm_dqppp(i,j)
        dqq(2,1,:) = dqq(1,2,:)
        
        xi(1) = qlm_xi_t(i,j,hn)
        xi(2) = qlm_xi_p(i,j,hn)
        
        dxi(1,1:2) = deriv (qlm_xi_t(:,:,hn), i, j, delta_space)
        dxi(2,1:2) = deriv (qlm_xi_p(:,:,hn), i, j, delta_space)
        
        ! L_xi q_ab = q_cb d_a xi^c + q_ac d_b xi^c + xi^c d_c q_ab
        do a=1,2
           do b=1,2
              lqq(a,b) = 0
              do c=1,2
                 lqq(a,b) = lqq(a,b) + qq(c,b) * dxi(c,a) &
                      &              + qq(a,c) * dxi(c,b) &
                      &              + xi(c) * dqq(a,b,c)
              end do
           end do
        end do
        
        qlm_lqtt(i,j,hn) = lqq(1,1)
        qlm_lqtp(i,j,hn) = lqq(1,2)
        qlm_lqpp(i,j,hn) = lqq(2,2)
        
     end do
  end do
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_lqtt(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_lqtp(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_lqpp(:,:,hn), +1)
  
end subroutine qlm_killing_test

```

qlm_killing_transport.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_killing_transport (CCTK_ARGUMENTS, hn)
  use cctk
  use constants
  use lapack
  use qlm_boundary
  use qlm_killing_transportation
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  interface
     integer function TAT_isnan (x)
       implicit none
       CCTK_REAL x
     end function TAT_isnan
  end interface
  
  integer, parameter :: lik = lapack_integer_kind

  CCTK_REAL    :: xi(2,3), chi(3)
  CCTK_REAL    :: vec(3,3)
  CCTK_REAL    :: wr(3), wi(3), vl(3,3), vr(3,3)
  integer      :: i0, j0
  integer      :: n
  integer(lik) :: info
  character    :: msg*1000
  
  integer(lik), parameter :: lwork = 100
  CCTK_REAL :: work(lwork)
  
  
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Transporting Killing vector field")
  end if
  
  
  
  ! latitude of "equator"
  i0 = (qlm_ntheta(hn)+1)/2
  ! longitude of zero meridian
  j0 = 1+qlm_nghostsphi(hn)
  
  vec = delta3
  
  if (veryverbose/=0) then
     write (msg, '("Initial vectors (xi^t xi^p chi):")')
     call CCTK_INFO (msg)
     do n=1,3
        write (msg, '(i2,3g18.8)') n, vec(:,n)
        call CCTK_INFO (msg)
     end do
  end if
  
  xi(1,:) = vec(1,:)
  xi(2,:) = vec(2,:)
  chi(:)  = vec(3,:)
  
  do n=1,3
     call transport_along_equator (CCTK_PASS_FTOF, hn, i0, xi(:,n), chi(n))
  end do
  
  vec(1,:) = xi(1,:)
  vec(2,:) = xi(2,:)
  vec(3,:) = chi(:)
  
  if (veryverbose/=0) then
     write (msg, '("Final vectors (xi^t xi^p chi):")')
     call CCTK_INFO (msg)
     do n=1,3
        write (msg, '(i2,3g18.8)') n, vec(:,n)
        call CCTK_INFO (msg)
     end do
  end if
  
  if (TAT_isnan(sum(vec)) /= 0) then
     ! qlm_calc_error(hn) = 1
     qlm_have_killing_vector(hn) = 0
     call CCTK_WARN (3, "There are nans in the final vectors")
     goto 9999
  end if
  
  call geev ('n', 'v', 3_lik, vec, 3_lik, wr, wi, vl, 3_lik, vr, 3_lik, &
       work, lwork, info)
  if (info/=0) then
     ! qlm_calc_error(hn) = 1
     qlm_have_killing_vector(hn) = 0
     write (msg, '("Error in call to GEEV, info=",i2)') info
     call CCTK_WARN (3, msg)
     goto 9999
  end if
  
  if (veryverbose/=0) then
     write (msg, '("Eigenvectors and eigenvalues:")')
     call CCTK_INFO (msg)
     do n=1,3
        write (msg, '(i2,3g18.8,(" (",g18.8,",",g18.8,")"))') &
             n, vr(:,n), wr(n), wi(n)
        call CCTK_INFO (msg)
     end do
  end if
  
  xi(1,:) = vr(1,:)
  xi(2,:) = vr(2,:)
  chi(:)  = vr(3,:)
  
  ! TODO:
  ! This transport scheme is not ideal.
  ! It leads to large fluctuations in the phi direction.
  n=3
  qlm_killing_eigenvalue_re(hn) = wr(n)
  qlm_killing_eigenvalue_im(hn) = wi(n)
  if (abs(cmplx(wr(n),wi(n),kind(wr)) - (1,0)) > 1.0d-4) then
     call CCTK_WARN (3, "Did not manage to find an eigenvector with the eigenvalue 1")
  end if
  call transport_along_equator (CCTK_PASS_FTOF, hn, i0, xi(:,n), chi(n))
  call transport_along_meridians (CCTK_PASS_FTOF, hn, i0)
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_xi_t(:,:,hn), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_xi_p(:,:,hn), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_chi (:,:,hn), +1)
  
9999 continue
end subroutine qlm_killing_transport

```

qlm_init.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_init (CCTK_ARGUMENTS)
  use cctk
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  
  integer :: hn
  
  if (verbose/=0 .or. veryverbose/=0) then
     call CCTK_INFO ("Initialising Quasi-Local Measure calculations")
  end if
  
  do hn = 1, num_surfaces
     
     qlm_calc_error(hn) = 1
     qlm_have_valid_data(hn) = 0
     qlm_have_valid_data_p(hn) = 0
     qlm_have_valid_data_p_p(hn) = 0
     qlm_have_killing_vector(hn) = 0
     qlm_have_killing_vector_p(hn) = 0
     qlm_have_killing_vector_p_p(hn) = 0
     qlm_iteration(hn) = -1
     
  end do
  
end subroutine qlm_init

```

qlm_paramcheck.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_paramcheck (CCTK_ARGUMENTS)
  use cctk
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer   :: hn
  integer   :: sn
  integer   :: eq_theta, new_ntheta, int_nphi, new_nphi
  character :: msg*1000
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Checking parameters")
  end if
  
  do hn = 1, num_surfaces
     
     if (surface_index(hn) == -1 .and. CCTK_EQUALS(surface_name(hn),"")) then
        ! no surface selected; everything is fine
        goto 9999
     end if
     
     if ((surface_index(hn) < 0 .or. surface_index(hn) >= nsurfaces) .and. &
         CCTK_EQUALS(surface_name(hn), "")) then
        write (msg, '("Illegal surface index specified for surface ",i4," (index is ",i4,", must be less than ",i4,")")') hn-1, surface_index(hn), nsurfaces
        call CCTK_PARAMWARN (msg)
        goto 9999
     end if
     
     sn = sf_IdFromName(surface_index(hn), surface_name(hn)) + 1
     
     ! Import surface description
     qlm_nghoststheta(hn) = nghoststheta(sn)
     qlm_nghostsphi  (hn) = nghostsphi(sn)
     qlm_ntheta      (hn) = ntheta(sn)
     qlm_nphi        (hn) = nphi(sn)
     
     ! Symmetries
     if (symmetric_x(sn) /= 0 .or. &
          symmetric_y(sn) /= 0 .or. &
          symmetric_z(sn) /= 0) then
        call CCTK_WARN (CCTK_WARN_ABORT, "SphericalSurface symmetries are not supported")
     end if
     
     if (auto_res(sn) /= 1 .and. (qlm_ntheta(hn) > maxntheta .or. qlm_nphi(hn) > maxnphi)) then
        write (msg, '("Surface ",i4," is too large: shape is (",2i6,"), maximum is (",2i6,")")') hn-1, qlm_ntheta(hn), qlm_nphi(hn), maxntheta, maxnphi
        call CCTK_PARAMWARN (msg)
     end if
     
     if (qlm_nghoststheta(hn)<1 .or. qlm_nghostsphi(hn)<1) then
        write (msg, '("Not enough ghost zones for surface ",i4,": nghosts=",2i4,", minimum is ",2i4)') hn-1, qlm_nghoststheta(hn), qlm_nghostsphi(hn), 1, 1
        call CCTK_PARAMWARN (msg)
     end if
     
     if (auto_res(sn) /= 1 .and. (mod(int(qlm_ntheta(hn) - 2*qlm_nghoststheta(hn)),2) /= 1)) then
        ! We need a grid point on the equator
        write (msg, '("The number of interior grid points in the theta direction of surface ",i4," must be odd after the symmetries have been removed, but it is ",i6)') hn-1, qlm_ntheta(hn) - 2*qlm_nghoststheta(hn)
        call CCTK_PARAMWARN (msg)
     end if
     
     if (auto_res(sn) /= 1 .and. (mod(int(qlm_nphi(hn) - 2*qlm_nghostsphi(hn)),4) /= 0)) then
        ! We need grid points on the four major meridians
        write (msg, '("The number of interior grid points in the phi direction of surface ",i4," must be a multiple of four after the symmetries have been removed, but it is ",i6)') hn-1, qlm_nphi(hn) - 2*qlm_nghostsphi(hn)
        call CCTK_PARAMWARN (msg)
     end if
     
9999 continue
  end do
  
end subroutine qlm_paramcheck

```

qlm_coordinates.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_calc_coordinates (CCTK_ARGUMENTS, hn)
  use cctk
  use constants
  use qlm_boundary
  use tensor2
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL, parameter :: one=1, two=2, half=one/two
  CCTK_REAL :: z0, z0dot, z1, z1dot
  CCTK_REAL :: qq(2,2), dtq
  CCTK_REAL :: integral_z, area, radius
  integer   :: i0,j0
  integer   :: i,j
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Finding invariant coordinates")
  end if
  
  ! latitude of "equator"
  i0 = (qlm_ntheta(hn)+1)/2
  ! longitude of zero meridian
  j0 = 1+qlm_nghostsphi(hn)
  
  
  
  ! calculate area
  area = 0
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        
        ! 2-metric on the horizon
        qq(1,1) = qlm_qtt(i,j,hn)
        qq(1,2) = qlm_qtp(i,j,hn)
        qq(2,2) = qlm_qpp(i,j,hn)
        qq(2,1) = qq(1,2)
        
        call calc_2det (qq, dtq)
        
        area = area + sqrt(dtq) * qlm_delta_theta(hn) * qlm_delta_phi(hn)
        
     end do
  end do
  radius = sqrt(area / (4*pi))
  
  
  
  ! initial value
  qlm_inv_z(i0,j0,hn) = 0
  
  ! d_a z = 1/R^2 xi^b eps_ba
  
  ! transport along equator
  do j = j0+1, qlm_nphi(hn)-qlm_nghostsphi(hn)
     i = i0
     
     z0 = qlm_inv_z(i,j-1,hn)
     z0dot = rhs(i,j-1,(/0,1/))
     z1 = z0 + qlm_delta_phi(hn) * z0dot
     z1dot = rhs(i,j,(/0,1/))
     qlm_inv_z(i,j,hn) = z0 + half * qlm_delta_phi(hn) * (z0dot + z1dot)
  end do
     
  ! transport along meridians
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = i0-1, 1+qlm_nghoststheta(hn), -1
        z0 = qlm_inv_z(i+1,j,hn)
        z0dot = rhs(i+1,j,(/-1,0/))
        z1 = z0 + qlm_delta_theta(hn) * z0dot
        z1dot = rhs(i,j,(/-1,0/))
        qlm_inv_z(i,j,hn) = z0 + half * qlm_delta_theta(hn) * (z0dot + z1dot)
     end do
     
     do i = i0+1, qlm_ntheta(hn)-qlm_nghoststheta(hn)
        z0 = qlm_inv_z(i-1,j,hn)
        z0dot = rhs(i-1,j,(/1,0/))
        z1 = z0 + qlm_delta_theta(hn) * z0dot
        z1dot = rhs(i,j,(/1,0/))
        qlm_inv_z(i,j,hn) = z0 + half * qlm_delta_theta(hn) * (z0dot + z1dot)
     end do
  end do
  
  ! normalise
  integral_z = 0
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        
        ! 2-metric on the horizon
        qq(1,1) = qlm_qtt(i,j,hn)
        qq(1,2) = qlm_qtp(i,j,hn)
        qq(2,2) = qlm_qpp(i,j,hn)
        qq(2,1) = qq(1,2)
        
        call calc_2det (qq, dtq)
        
        integral_z = integral_z + qlm_inv_z(i,j,hn) * sqrt(dtq) * qlm_delta_theta(hn) * qlm_delta_phi(hn)
        
     end do
  end do
  qlm_inv_z(:,:,hn) = qlm_inv_z(:,:,hn) - integral_z / area
  
  ! boundary conditions
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_inv_z(:,:,hn), +1)
  
  
  
#if 0
  
  ! initial value
  qlm_inv_phi(i0,j0,hn) = 0
  
  ! xi^a d_a phi = C
  ! z^a d_a phi = 0
  ! z^a = (R^4 / q_bc xi^b xi^c) q^ab d_b z
  ! v^a = A z^a + B xi^a
  ! v^a d_a phi = (A z^a + B xi^a) d_a phi
  !             = B C
  ! (choose C=1, and normalise later)
  
#error "replace z by phi"
  ! transport along equator
  do j = j0+1, qlm_nphi(hn)-qlm_nghostsphi(hn)
     i = i0
     
     z0 = qlm_inv_z(i,j-1,hn)
     z0dot = rhs(i,j-1,(/0,1/))
     z1 = z0 + qlm_delta_phi(hn) * z0dot
     z1dot = rhs(i,j,(/0,1/))
     qlm_inv_z(i,j,hn) = z0 + half * qlm_delta_phi(hn) * (z0dot + z1dot)
  end do
     
  ! transport along meridians
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = i0-1, 1+qlm_nghoststheta(hn), -1
        z0 = qlm_inv_z(i+1,j,hn)
        z0dot = rhs(i+1,j,(/-1,0/))
        z1 = z0 + qlm_delta_theta(hn) * z0dot
        z1dot = rhs(i,j,(/-1,0/))
        qlm_inv_z(i,j,hn) = z0 + half * qlm_delta_theta(hn) * (z0dot + z1dot)
     end do
     
     do i = i0+1, qlm_ntheta(hn)-qlm_nghoststheta(hn)
        z0 = qlm_inv_z(i-1,j,hn)
        z0dot = rhs(i-1,j,(/1,0/))
        z1 = z0 + qlm_delta_theta(hn) * z0dot
        z1dot = rhs(i,j,(/1,0/))
        qlm_inv_z(i,j,hn) = z0 + half * qlm_delta_theta(hn) * (z0dot + z1dot)
     end do
  end do
  
#error "normalise"
  
#endif
  
contains
  
  function rhs (i, j, vv) result (zdot)
    integer,   intent(in) :: i, j
    integer,   intent(in) :: vv(2)
    CCTK_REAL             :: zdot
    CCTK_REAL :: qq(2,2), dtq
    
    ! 2-metric on the horizon
    qq(1,1) = qlm_qtt(i,j,hn)
    qq(1,2) = qlm_qtp(i,j,hn)
    qq(2,2) = qlm_qpp(i,j,hn)
    qq(2,1) = qq(1,2)
    
    call calc_2det (qq, dtq)
    
    zdot = vv(1) * (- (1/radius**2) * qlm_xi_p(i,j,hn) * sqrt(dtq)) &
         + vv(2) * (+ (1/radius**2) * qlm_xi_t(i,j,hn) * sqrt(dtq))
  end function rhs
  
end subroutine qlm_calc_coordinates

```

make.code.defn:
```
# Main make.code.defn file for thorn QuasiLocalMeasures   -*-Makefile-*-

# Source files in this directory
SRCS =  qlm_3determinant.F90			\
        qlm_analyse.F90				\
        qlm_boundary.F90			\
        qlm_broadcast.c				\
        qlm_calculate.F90			\
        qlm_coordinates.F90			\
        qlm_derivs.F90				\
        qlm_gram_schmidt.F90			\
        qlm_import_surface.F90			\
        qlm_init.F90				\
        qlm_interpolate.F90			\
        qlm_killing_axial.F90			\
        qlm_killing_gradient.F90		\
        qlm_killing_normalisation.F90		\
        qlm_killing_normalise.F90		\
        qlm_killing_test.F90			\
        qlm_killing_transport.F90		\
        qlm_killing_transportation.F90		\
        qlm_multipoles.F90			\
        qlm_newman_penrose.F90			\
        qlm_output_vtk.F90			\
        qlm_paramcheck.F90			\
        qlm_set_coordinates.F90			\
        qlm_tetrad.F90				\
        qlm_twometric.F90			\
        qlm_variables.F90			\
        qlm_weyl_scalars.F90

# Subdirectories containing source files
SUBDIRS = 

```

qlm_interpolate.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



! TODO:
! instead of interpolating to the symmetry points, copy them



! A convenient shortcut
#define P(x) CCTK_PointerTo(x)



subroutine qlm_interpolate (CCTK_ARGUMENTS, hn)
  use cctk
  use qlm_variables
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_INT,  parameter :: izero = 0
  integer,   parameter :: ik = kind(izero)
  integer,   parameter :: sk = kind(interpolator)
  CCTK_REAL, parameter :: one = 1
  
  CCTK_REAL, parameter :: poison_value = -42
  
  integer      :: len_coordsystem
  integer      :: len_interpolator
  integer      :: len_interpolator_options
  
  character    :: fort_coordsystem*100
  character    :: fort_interpolator*100
  character    :: fort_interpolator_options*1000
  
  integer      :: nvars
  
  integer      :: coord_handle
  integer      :: interp_handle
  integer      :: options_table
  
  integer      :: ninputs
  integer      :: noutputs
  
  CCTK_REAL, allocatable :: xcoord(:,:)
  CCTK_REAL, allocatable :: ycoord(:,:)
  CCTK_REAL, allocatable :: zcoord(:,:)
  
  integer      :: ind_gxx, ind_gxy, ind_gxz, ind_gyy, ind_gyz, ind_gzz
  integer      :: ind_kxx, ind_kxy, ind_kxz, ind_kyy, ind_kyz, ind_kzz
  integer      :: ind_alpha
  integer      :: ind_betax, ind_betay, ind_betaz
  integer      :: ind_ttt
  integer      :: ind_ttx, ind_tty, ind_ttz
  integer      :: ind_txx, ind_txy, ind_txz, ind_tyy, ind_tyz, ind_tzz
  
  integer      :: coord_type
  CCTK_POINTER :: coords(3)
  CCTK_INT     :: inputs(26)
  CCTK_INT     :: output_types(98)
  CCTK_POINTER :: outputs(98)
  CCTK_INT     :: operand_indices(98)
  CCTK_INT     :: operation_codes(98)
  integer      :: npoints
  
  character    :: msg*1000
  
  integer      :: ni, nj
  
  integer      :: ierr
  
  
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Interpolating 3d grid functions")
  end if
  
  
  
  if (shift_state==0) then
     call CCTK_WARN (0, "The shift must have storage")
  end if
  
!!$  if (stress_energy_state==0) then
!!$     call CCTK_WARN (0, "The stress-energy tensor must have storage")
!!$  end if
  
  
  
  ! Get coordinate system
  call CCTK_FortranString &
       (len_coordsystem, int(coordsystem,sk), fort_coordsystem)
  call CCTK_CoordSystemHandle (coord_handle, fort_coordsystem)
  if (coord_handle<0) then
     write (msg, '("The coordinate system """, a, """ does not exist")') &
          trim(fort_coordsystem)
     call CCTK_WARN (0, msg)
  end if
  
  ! Get interpolator
  call CCTK_FortranString &
       (len_interpolator, int(interpolator,sk), fort_interpolator)
  call CCTK_InterpHandle (interp_handle, fort_interpolator)
  if (interp_handle<0) then
     write (msg, '("The interpolator """,a,""" does not exist")') &
          trim(fort_interpolator)
     call CCTK_WARN (0, msg)
  end if
  
  ! Get interpolator options
  call CCTK_FortranString &
       (len_interpolator_options, int(interpolator_options,sk), &
       fort_interpolator_options)
  call Util_TableCreateFromString (options_table, fort_interpolator_options)
  if (options_table<0) then
     write (msg, '("The interpolator_options """,a,""" have a wrong syntax")') &
          trim(fort_interpolator_options)
     call CCTK_WARN (0, msg)
  end if
  
  
  
  if (hn > 0) then
     
     ni = qlm_ntheta(hn)
     nj = qlm_nphi(hn)
     
     allocate (xcoord(ni,nj))
     allocate (ycoord(ni,nj))
     allocate (zcoord(ni,nj))
     
     xcoord(:,:) = qlm_x(:ni,:nj,hn)
     ycoord(:,:) = qlm_y(:ni,:nj,hn)
     zcoord(:,:) = qlm_z(:ni,:nj,hn)
     
  end if
  
  
  
  ! TODO: check the excision mask
  
  ! Get variable indices
  call CCTK_VarIndex (ind_gxx  , "ADMBase::gxx"   )
  call CCTK_VarIndex (ind_gxy  , "ADMBase::gxy"   )
  call CCTK_VarIndex (ind_gxz  , "ADMBase::gxz"   )
  call CCTK_VarIndex (ind_gyy  , "ADMBase::gyy"   )
  call CCTK_VarIndex (ind_gyz  , "ADMBase::gyz"   )
  call CCTK_VarIndex (ind_gzz  , "ADMBase::gzz"   )
  call CCTK_VarIndex (ind_kxx  , "ADMBase::kxx"   )
  call CCTK_VarIndex (ind_kxy  , "ADMBase::kxy"   )
  call CCTK_VarIndex (ind_kxz  , "ADMBase::kxz"   )
  call CCTK_VarIndex (ind_kyy  , "ADMBase::kyy"   )
  call CCTK_VarIndex (ind_kyz  , "ADMBase::kyz"   )
  call CCTK_VarIndex (ind_kzz  , "ADMBase::kzz"   )
  call CCTK_VarIndex (ind_alpha, "ADMBase::alp"   )
  call CCTK_VarIndex (ind_betax, "ADMBase::betax" )
  call CCTK_VarIndex (ind_betay, "ADMBase::betay" )
  call CCTK_VarIndex (ind_betaz, "ADMBase::betaz" )
  if (stress_energy_state /= 0) then
     call CCTK_VarIndex (ind_ttt  , "TmunuBase::eTtt")
     call CCTK_VarIndex (ind_ttx  , "TmunuBase::eTtx")
     call CCTK_VarIndex (ind_tty  , "TmunuBase::eTty")
     call CCTK_VarIndex (ind_ttz  , "TmunuBase::eTtz")
     call CCTK_VarIndex (ind_txx  , "TmunuBase::eTxx")
     call CCTK_VarIndex (ind_txy  , "TmunuBase::eTxy")
     call CCTK_VarIndex (ind_txz  , "TmunuBase::eTxz")
     call CCTK_VarIndex (ind_tyy  , "TmunuBase::eTyy")
     call CCTK_VarIndex (ind_tyz  , "TmunuBase::eTyz")
     call CCTK_VarIndex (ind_tzz  , "TmunuBase::eTzz")
  else
     ind_ttt = -1
     ind_ttx = -1
     ind_tty = -1
     ind_ttz = -1
     ind_txx = -1
     ind_txy = -1
     ind_txz = -1
     ind_tyy = -1
     ind_tyz = -1
     ind_tzz = -1
  end if
  
  
  
  ! Set up the interpolator arguments
  coord_type = CCTK_VARIABLE_REAL
  if (hn > 0) then
     npoints = ni * nj
     coords(:) = (/ P(xcoord), P(ycoord), P(zcoord) /)
  else
     npoints = 0
     coords(:) = CCTK_NullPointer()
  end if
  
  inputs = (/ &
       ind_gxx, ind_gxy, ind_gxz, ind_gyy, ind_gyz, ind_gzz, &
       ind_kxx, ind_kxy, ind_kxz, ind_kyy, ind_kyz, ind_kzz, &
       ind_alpha, &
       ind_betax, ind_betay, ind_betaz, &
       ind_ttt, &
       ind_ttx, ind_tty, ind_ttz, &
       ind_txx, ind_txy, ind_txz, ind_tyy, ind_tyz, ind_tzz /)
  
  call CCTK_NumVars (nvars)
  if (nvars < 0) call CCTK_WARN (0, "internal error")
  if (any(inputs /= -1 .and. (inputs < 0 .or. inputs >= nvars))) then
     call CCTK_WARN (0, "internal error")
  end if
  
  operand_indices = (/ &
       00, 01, 02, 03, 04, 05, & ! g_ij
       00, 01, 02, 03, 04, 05, & ! g_ij,k
       00, 01, 02, 03, 04, 05, &
       00, 01, 02, 03, 04, 05, &
       00, 01, 02, 03, 04, 05, & ! g_ij,kl
       00, 01, 02, 03, 04, 05, &
       00, 01, 02, 03, 04, 05, &
       00, 01, 02, 03, 04, 05, &
       00, 01, 02, 03, 04, 05, &
       00, 01, 02, 03, 04, 05, &
       06, 07, 08, 09, 10, 11, & ! K_ij
       06, 07, 08, 09, 10, 11, & ! K_ij,k
       06, 07, 08, 09, 10, 11, &
       06, 07, 08, 09, 10, 11, &
       12, &                    ! alp
       13, 14, 15, &            ! beta^i
       16, &                    ! T_tt
       17, 18, 19, &            ! T_ti
       20, 21, 22, 23, 24, 25 /) ! T_ij
  
  operation_codes = (/ &
       0, 0, 0, 0, 0, 0, &      ! g_ij
       1, 1, 1, 1, 1, 1, &      ! g_ij,k
       2, 2, 2, 2, 2, 2, &
       3, 3, 3, 3, 3, 3, &
       11, 11, 11, 11, 11, 11, & ! g_ij,kl
       12, 12, 12, 12, 12, 12, &
       13, 13, 13, 13, 13, 13, &
       22, 22, 22, 22, 22, 22, &
       23, 23, 23, 23, 23, 23, &
       33, 33, 33, 33, 33, 33, &
       0, 0, 0, 0, 0, 0, &      ! K_ij
       1, 1, 1, 1, 1, 1, &      ! K_ij,k
       2, 2, 2, 2, 2, 2, &
       3, 3, 3, 3, 3, 3, &
       0, &                     ! alp
       0, 0, 0, &               ! beta^i
       0, &                     ! T_tt
       0, 0, 0, &               ! T_ti
       0, 0, 0, 0, 0, 0 /)      ! T_ij
  
  output_types(:) = CCTK_VARIABLE_REAL
  if (hn > 0) then
     outputs = (/ &
          P(qlm_gxx), P(qlm_gxy), P(qlm_gxz), P(qlm_gyy), P(qlm_gyz), P(qlm_gzz), &
          P(qlm_dgxxx), P(qlm_dgxyx), P(qlm_dgxzx), P(qlm_dgyyx), P(qlm_dgyzx), P(qlm_dgzzx), &
          P(qlm_dgxxy), P(qlm_dgxyy), P(qlm_dgxzy), P(qlm_dgyyy), P(qlm_dgyzy), P(qlm_dgzzy), &
          P(qlm_dgxxz), P(qlm_dgxyz), P(qlm_dgxzz), P(qlm_dgyyz), P(qlm_dgyzz), P(qlm_dgzzz), &
          P(qlm_ddgxxxx), P(qlm_ddgxyxx), P(qlm_ddgxzxx), P(qlm_ddgyyxx), P(qlm_ddgyzxx), P(qlm_ddgzzxx), &
          P(qlm_ddgxxxy), P(qlm_ddgxyxy), P(qlm_ddgxzxy), P(qlm_ddgyyxy), P(qlm_ddgyzxy), P(qlm_ddgzzxy), &
          P(qlm_ddgxxxz), P(qlm_ddgxyxz), P(qlm_ddgxzxz), P(qlm_ddgyyxz), P(qlm_ddgyzxz), P(qlm_ddgzzxz), &
          P(qlm_ddgxxyy), P(qlm_ddgxyyy), P(qlm_ddgxzyy), P(qlm_ddgyyyy), P(qlm_ddgyzyy), P(qlm_ddgzzyy), &
          P(qlm_ddgxxyz), P(qlm_ddgxyyz), P(qlm_ddgxzyz), P(qlm_ddgyyyz), P(qlm_ddgyzyz), P(qlm_ddgzzyz), &
          P(qlm_ddgxxzz), P(qlm_ddgxyzz), P(qlm_ddgxzzz), P(qlm_ddgyyzz), P(qlm_ddgyzzz), P(qlm_ddgzzzz), &
          P(qlm_kxx), P(qlm_kxy), P(qlm_kxz), P(qlm_kyy), P(qlm_kyz), P(qlm_kzz), &
          P(qlm_dkxxx), P(qlm_dkxyx), P(qlm_dkxzx), P(qlm_dkyyx), P(qlm_dkyzx), P(qlm_dkzzx), &
          P(qlm_dkxxy), P(qlm_dkxyy), P(qlm_dkxzy), P(qlm_dkyyy), P(qlm_dkyzy), P(qlm_dkzzy), &
          P(qlm_dkxxz), P(qlm_dkxyz), P(qlm_dkxzz), P(qlm_dkyyz), P(qlm_dkyzz), P(qlm_dkzzz), &
          P(qlm_alpha), &
          P(qlm_betax), P(qlm_betay), P(qlm_betaz), &
          P(qlm_ttt), &
          P(qlm_ttx), P(qlm_tty), P(qlm_ttz), &
          P(qlm_txx), P(qlm_txy), P(qlm_txz), P(qlm_tyy), P(qlm_tyz), P(qlm_tzz) /)
  else
     outputs(:) = CCTK_NullPointer()
  end if
  
  
  
  ninputs = size(inputs)
  noutputs = size(outputs)
  
  
  
#if 0
  ! Poison the output variables
  call poison (qlm_gxx    )
  call poison (qlm_gxy    )
  call poison (qlm_gxz    )
  call poison (qlm_gyy    )
  call poison (qlm_gyz    )
  call poison (qlm_gzz    )
  call poison (qlm_dgxxx  )
  call poison (qlm_dgxyx  )
  call poison (qlm_dgxzx  )
  call poison (qlm_dgyyx  )
  call poison (qlm_dgyzx  )
  call poison (qlm_dgzzx  )
  call poison (qlm_dgxxy  )
  call poison (qlm_dgxyy  )
  call poison (qlm_dgxzy  )
  call poison (qlm_dgyyy  )
  call poison (qlm_dgyzy  )
  call poison (qlm_dgzzy  )
  call poison (qlm_dgxxz  )
  call poison (qlm_dgxyz  )
  call poison (qlm_dgxzz  )
  call poison (qlm_dgyyz  )
  call poison (qlm_dgyzz  )
  call poison (qlm_dgzzz  )
  call poison (qlm_ddgxxxx)
  call poison (qlm_ddgxyxx)
  call poison (qlm_ddgxzxx)
  call poison (qlm_ddgyyxx)
  call poison (qlm_ddgyzxx)
  call poison (qlm_ddgzzxx)
  call poison (qlm_ddgxxxy)
  call poison (qlm_ddgxyxy)
  call poison (qlm_ddgxzxy)
  call poison (qlm_ddgyyxy)
  call poison (qlm_ddgyzxy)
  call poison (qlm_ddgzzxy)
  call poison (qlm_ddgxxxz)
  call poison (qlm_ddgxyxz)
  call poison (qlm_ddgxzxz)
  call poison (qlm_ddgyyxz)
  call poison (qlm_ddgyzxz)
  call poison (qlm_ddgzzxz)
  call poison (qlm_ddgxxyy)
  call poison (qlm_ddgxyyy)
  call poison (qlm_ddgxzyy)
  call poison (qlm_ddgyyyy)
  call poison (qlm_ddgyzyy)
  call poison (qlm_ddgzzyy)
  call poison (qlm_ddgxxyz)
  call poison (qlm_ddgxyyz)
  call poison (qlm_ddgxzyz)
  call poison (qlm_ddgyyyz)
  call poison (qlm_ddgyzyz)
  call poison (qlm_ddgzzyz)
  call poison (qlm_ddgxxzz)
  call poison (qlm_ddgxyzz)
  call poison (qlm_ddgxzzz)
  call poison (qlm_ddgyyzz)
  call poison (qlm_ddgyzzz)
  call poison (qlm_ddgzzzz)
  call poison (qlm_kxx    )
  call poison (qlm_kxy    )
  call poison (qlm_kxz    )
  call poison (qlm_kyy    )
  call poison (qlm_kyz    )
  call poison (qlm_kzz    )
  call poison (qlm_dkxxx  )
  call poison (qlm_dkxyx  )
  call poison (qlm_dkxzx  )
  call poison (qlm_dkyyx  )
  call poison (qlm_dkyzx  )
  call poison (qlm_dkzzx  )
  call poison (qlm_dkxxy  )
  call poison (qlm_dkxyy  )
  call poison (qlm_dkxzy  )
  call poison (qlm_dkyyy  )
  call poison (qlm_dkyzy  )
  call poison (qlm_dkzzy  )
  call poison (qlm_dkxxz  )
  call poison (qlm_dkxyz  )
  call poison (qlm_dkxzz  )
  call poison (qlm_dkyyz  )
  call poison (qlm_dkyzz  )
  call poison (qlm_dkzzz  )
  call poison (qlm_alpha  )
  call poison (qlm_betax  )
  call poison (qlm_betay  )
  call poison (qlm_betaz  )
  call poison (qlm_ttt    )
  call poison (qlm_ttx    )
  call poison (qlm_tty    )
  call poison (qlm_ttz    )
  call poison (qlm_txx    )
  call poison (qlm_txy    )
  call poison (qlm_txz    )
  call poison (qlm_tyy    )
  call poison (qlm_tyz    )
  call poison (qlm_tzz    )
#endif
  
  
  
  ! Call the interpolator
  call Util_TableSetIntArray &
       (ierr, options_table, noutputs, &
       operand_indices, "operand_indices")
  if (ierr /= 0) call CCTK_WARN (0, "internal error")
  call Util_TableSetIntArray &
       (ierr, options_table, noutputs, &
       operation_codes, "operation_codes")
  if (ierr /= 0) call CCTK_WARN (0, "internal error")
  
  call CCTK_InterpGridArrays &
       (ierr, cctkGH, 3, &
       interp_handle, options_table, coord_handle, &
       npoints, coord_type, coords, &
       ninputs, inputs, &
       noutputs, output_types, outputs)
  
  if (ierr /= 0) then
     if (hn > 0) then
        qlm_calc_error(hn) = 1
     end if
     call CCTK_WARN (1, "Interpolator failed")
     return
  end if
  
  
  
  ! Unpack the variables
  if (hn > 0) then
     
     call unpack (qlm_gxx    , ni, nj)
     call unpack (qlm_gxy    , ni, nj)
     call unpack (qlm_gxz    , ni, nj)
     call unpack (qlm_gyy    , ni, nj)
     call unpack (qlm_gyz    , ni, nj)
     call unpack (qlm_gzz    , ni, nj)
     call unpack (qlm_dgxxx  , ni, nj)
     call unpack (qlm_dgxyx  , ni, nj)
     call unpack (qlm_dgxzx  , ni, nj)
     call unpack (qlm_dgyyx  , ni, nj)
     call unpack (qlm_dgyzx  , ni, nj)
     call unpack (qlm_dgzzx  , ni, nj)
     call unpack (qlm_dgxxy  , ni, nj)
     call unpack (qlm_dgxyy  , ni, nj)
     call unpack (qlm_dgxzy  , ni, nj)
     call unpack (qlm_dgyyy  , ni, nj)
     call unpack (qlm_dgyzy  , ni, nj)
     call unpack (qlm_dgzzy  , ni, nj)
     call unpack (qlm_dgxxz  , ni, nj)
     call unpack (qlm_dgxyz  , ni, nj)
     call unpack (qlm_dgxzz  , ni, nj)
     call unpack (qlm_dgyyz  , ni, nj)
     call unpack (qlm_dgyzz  , ni, nj)
     call unpack (qlm_dgzzz  , ni, nj)
     call unpack (qlm_ddgxxxx, ni, nj)
     call unpack (qlm_ddgxyxx, ni, nj)
     call unpack (qlm_ddgxzxx, ni, nj)
     call unpack (qlm_ddgyyxx, ni, nj)
     call unpack (qlm_ddgyzxx, ni, nj)
     call unpack (qlm_ddgzzxx, ni, nj)
     call unpack (qlm_ddgxxxy, ni, nj)
     call unpack (qlm_ddgxyxy, ni, nj)
     call unpack (qlm_ddgxzxy, ni, nj)
     call unpack (qlm_ddgyyxy, ni, nj)
     call unpack (qlm_ddgyzxy, ni, nj)
     call unpack (qlm_ddgzzxy, ni, nj)
     call unpack (qlm_ddgxxxz, ni, nj)
     call unpack (qlm_ddgxyxz, ni, nj)
     call unpack (qlm_ddgxzxz, ni, nj)
     call unpack (qlm_ddgyyxz, ni, nj)
     call unpack (qlm_ddgyzxz, ni, nj)
     call unpack (qlm_ddgzzxz, ni, nj)
     call unpack (qlm_ddgxxyy, ni, nj)
     call unpack (qlm_ddgxyyy, ni, nj)
     call unpack (qlm_ddgxzyy, ni, nj)
     call unpack (qlm_ddgyyyy, ni, nj)
     call unpack (qlm_ddgyzyy, ni, nj)
     call unpack (qlm_ddgzzyy, ni, nj)
     call unpack (qlm_ddgxxyz, ni, nj)
     call unpack (qlm_ddgxyyz, ni, nj)
     call unpack (qlm_ddgxzyz, ni, nj)
     call unpack (qlm_ddgyyyz, ni, nj)
     call unpack (qlm_ddgyzyz, ni, nj)
     call unpack (qlm_ddgzzyz, ni, nj)
     call unpack (qlm_ddgxxzz, ni, nj)
     call unpack (qlm_ddgxyzz, ni, nj)
     call unpack (qlm_ddgxzzz, ni, nj)
     call unpack (qlm_ddgyyzz, ni, nj)
     call unpack (qlm_ddgyzzz, ni, nj)
     call unpack (qlm_ddgzzzz, ni, nj)
     call unpack (qlm_kxx    , ni, nj)
     call unpack (qlm_kxy    , ni, nj)
     call unpack (qlm_kxz    , ni, nj)
     call unpack (qlm_kyy    , ni, nj)
     call unpack (qlm_kyz    , ni, nj)
     call unpack (qlm_kzz    , ni, nj)
     call unpack (qlm_dkxxx  , ni, nj)
     call unpack (qlm_dkxyx  , ni, nj)
     call unpack (qlm_dkxzx  , ni, nj)
     call unpack (qlm_dkyyx  , ni, nj)
     call unpack (qlm_dkyzx  , ni, nj)
     call unpack (qlm_dkzzx  , ni, nj)
     call unpack (qlm_dkxxy  , ni, nj)
     call unpack (qlm_dkxyy  , ni, nj)
     call unpack (qlm_dkxzy  , ni, nj)
     call unpack (qlm_dkyyy  , ni, nj)
     call unpack (qlm_dkyzy  , ni, nj)
     call unpack (qlm_dkzzy  , ni, nj)
     call unpack (qlm_dkxxz  , ni, nj)
     call unpack (qlm_dkxyz  , ni, nj)
     call unpack (qlm_dkxzz  , ni, nj)
     call unpack (qlm_dkyyz  , ni, nj)
     call unpack (qlm_dkyzz  , ni, nj)
     call unpack (qlm_dkzzz  , ni, nj)
     call unpack (qlm_alpha  , ni, nj)
     call unpack (qlm_betax  , ni, nj)
     call unpack (qlm_betay  , ni, nj)
     call unpack (qlm_betaz  , ni, nj)
     if (stress_energy_state /= 0) then
        call unpack (qlm_ttt    , ni, nj)
        call unpack (qlm_ttx    , ni, nj)
        call unpack (qlm_tty    , ni, nj)
        call unpack (qlm_ttz    , ni, nj)
        call unpack (qlm_txx    , ni, nj)
        call unpack (qlm_txy    , ni, nj)
        call unpack (qlm_txz    , ni, nj)
        call unpack (qlm_tyy    , ni, nj)
        call unpack (qlm_tyz    , ni, nj)
        call unpack (qlm_tzz    , ni, nj)
     else
        qlm_ttt = 0
        qlm_ttx = 0
        qlm_tty = 0
        qlm_ttz = 0
        qlm_txx = 0
        qlm_txy = 0
        qlm_txz = 0
        qlm_tyy = 0
        qlm_tyz = 0
        qlm_tzz = 0
     end if
     
     
     
#if 0
     ! Check for poison
     call poison_check (qlm_gxx    , "qlm_gxx    ")
     call poison_check (qlm_gxy    , "qlm_gxy    ")
     call poison_check (qlm_gxz    , "qlm_gxz    ")
     call poison_check (qlm_gyy    , "qlm_gyy    ")
     call poison_check (qlm_gyz    , "qlm_gyz    ")
     call poison_check (qlm_gzz    , "qlm_gzz    ")
     call poison_check (qlm_dgxxx  , "qlm_dgxxx  ")
     call poison_check (qlm_dgxyx  , "qlm_dgxyx  ")
     call poison_check (qlm_dgxzx  , "qlm_dgxzx  ")
     call poison_check (qlm_dgyyx  , "qlm_dgyyx  ")
     call poison_check (qlm_dgyzx  , "qlm_dgyzx  ")
     call poison_check (qlm_dgzzx  , "qlm_dgzzx  ")
     call poison_check (qlm_dgxxy  , "qlm_dgxxy  ")
     call poison_check (qlm_dgxyy  , "qlm_dgxyy  ")
     call poison_check (qlm_dgxzy  , "qlm_dgxzy  ")
     call poison_check (qlm_dgyyy  , "qlm_dgyyy  ")
     call poison_check (qlm_dgyzy  , "qlm_dgyzy  ")
     call poison_check (qlm_dgzzy  , "qlm_dgzzy  ")
     call poison_check (qlm_dgxxz  , "qlm_dgxxz  ")
     call poison_check (qlm_dgxyz  , "qlm_dgxyz  ")
     call poison_check (qlm_dgxzz  , "qlm_dgxzz  ")
     call poison_check (qlm_dgyyz  , "qlm_dgyyz  ")
     call poison_check (qlm_dgyzz  , "qlm_dgyzz  ")
     call poison_check (qlm_dgzzz  , "qlm_dgzzz  ")
     call poison_check (qlm_ddgxxxx, "qlm_ddgxxxx")
     call poison_check (qlm_ddgxyxx, "qlm_ddgxyxx")
     call poison_check (qlm_ddgxzxx, "qlm_ddgxzxx")
     call poison_check (qlm_ddgyyxx, "qlm_ddgyyxx")
     call poison_check (qlm_ddgyzxx, "qlm_ddgyzxx")
     call poison_check (qlm_ddgzzxx, "qlm_ddgzzxx")
     call poison_check (qlm_ddgxxxy, "qlm_ddgxxxy")
     call poison_check (qlm_ddgxyxy, "qlm_ddgxyxy")
     call poison_check (qlm_ddgxzxy, "qlm_ddgxzxy")
     call poison_check (qlm_ddgyyxy, "qlm_ddgyyxy")
     call poison_check (qlm_ddgyzxy, "qlm_ddgyzxy")
     call poison_check (qlm_ddgzzxy, "qlm_ddgzzxy")
     call poison_check (qlm_ddgxxxz, "qlm_ddgxxxz")
     call poison_check (qlm_ddgxyxz, "qlm_ddgxyxz")
     call poison_check (qlm_ddgxzxz, "qlm_ddgxzxz")
     call poison_check (qlm_ddgyyxz, "qlm_ddgyyxz")
     call poison_check (qlm_ddgyzxz, "qlm_ddgyzxz")
     call poison_check (qlm_ddgzzxz, "qlm_ddgzzxz")
     call poison_check (qlm_ddgxxyy, "qlm_ddgxxyy")
     call poison_check (qlm_ddgxyyy, "qlm_ddgxyyy")
     call poison_check (qlm_ddgxzyy, "qlm_ddgxzyy")
     call poison_check (qlm_ddgyyyy, "qlm_ddgyyyy")
     call poison_check (qlm_ddgyzyy, "qlm_ddgyzyy")
     call poison_check (qlm_ddgzzyy, "qlm_ddgzzyy")
     call poison_check (qlm_ddgxxyz, "qlm_ddgxxyz")
     call poison_check (qlm_ddgxyyz, "qlm_ddgxyyz")
     call poison_check (qlm_ddgxzyz, "qlm_ddgxzyz")
     call poison_check (qlm_ddgyyyz, "qlm_ddgyyyz")
     call poison_check (qlm_ddgyzyz, "qlm_ddgyzyz")
     call poison_check (qlm_ddgzzyz, "qlm_ddgzzyz")
     call poison_check (qlm_ddgxxzz, "qlm_ddgxxzz")
     call poison_check (qlm_ddgxyzz, "qlm_ddgxyzz")
     call poison_check (qlm_ddgxzzz, "qlm_ddgxzzz")
     call poison_check (qlm_ddgyyzz, "qlm_ddgyyzz")
     call poison_check (qlm_ddgyzzz, "qlm_ddgyzzz")
     call poison_check (qlm_ddgzzzz, "qlm_ddgzzzz")
     call poison_check (qlm_kxx    , "qlm_kxx    ")
     call poison_check (qlm_kxy    , "qlm_kxy    ")
     call poison_check (qlm_kxz    , "qlm_kxz    ")
     call poison_check (qlm_kyy    , "qlm_kyy    ")
     call poison_check (qlm_kyz    , "qlm_kyz    ")
     call poison_check (qlm_kzz    , "qlm_kzz    ")
     call poison_check (qlm_dkxxx  , "qlm_dkxxx  ")
     call poison_check (qlm_dkxyx  , "qlm_dkxyx  ")
     call poison_check (qlm_dkxzx  , "qlm_dkxzx  ")
     call poison_check (qlm_dkyyx  , "qlm_dkyyx  ")
     call poison_check (qlm_dkyzx  , "qlm_dkyzx  ")
     call poison_check (qlm_dkzzx  , "qlm_dkzzx  ")
     call poison_check (qlm_dkxxy  , "qlm_dkxxy  ")
     call poison_check (qlm_dkxyy  , "qlm_dkxyy  ")
     call poison_check (qlm_dkxzy  , "qlm_dkxzy  ")
     call poison_check (qlm_dkyyy  , "qlm_dkyyy  ")
     call poison_check (qlm_dkyzy  , "qlm_dkyzy  ")
     call poison_check (qlm_dkzzy  , "qlm_dkzzy  ")
     call poison_check (qlm_dkxxz  , "qlm_dkxxz  ")
     call poison_check (qlm_dkxyz  , "qlm_dkxyz  ")
     call poison_check (qlm_dkxzz  , "qlm_dkxzz  ")
     call poison_check (qlm_dkyyz  , "qlm_dkyyz  ")
     call poison_check (qlm_dkyzz  , "qlm_dkyzz  ")
     call poison_check (qlm_dkzzz  , "qlm_dkzzz  ")
     call poison_check (qlm_alpha  , "qlm_alpha  ")
     call poison_check (qlm_betax  , "qlm_betax  ")
     call poison_check (qlm_betay  , "qlm_betay  ")
     call poison_check (qlm_betaz  , "qlm_betaz  ")
     call poison_check (qlm_ttt    , "qlm_ttt    ")
     call poison_check (qlm_ttx    , "qlm_ttx    ")
     call poison_check (qlm_tty    , "qlm_tty    ")
     call poison_check (qlm_ttz    , "qlm_ttz    ")
     call poison_check (qlm_txx    , "qlm_txx    ")
     call poison_check (qlm_txy    , "qlm_txy    ")
     call poison_check (qlm_txz    , "qlm_txz    ")
     call poison_check (qlm_tyy    , "qlm_tyy    ")
     call poison_check (qlm_tyz    , "qlm_tyz    ")
     call poison_check (qlm_tzz    , "qlm_tzz    ")
#endif
     
  end if
  
  
  
  ! Free interpolator options
  call Util_TableDestroy (ierr, options_table)
  
  
  
  if (hn > 0) then
     
     qlm_have_valid_data(hn) = 1
     
     deallocate (xcoord)
     deallocate (ycoord)
     deallocate (zcoord)
     
  end if
  
  
  
contains
  
  subroutine pack (arr, ni, nj)
    integer,   intent(in)    :: ni, nj
    CCTK_REAL, intent(inout) :: arr(:,:)
    CCTK_REAL :: tmp(ni,nj)
    tmp(:,:) = arr(:ni, :nj)
    call copy (arr, tmp, size(tmp))
  end subroutine pack
  
  subroutine unpack (arr, ni, nj)
    integer,   intent(in)    :: ni, nj
    CCTK_REAL, intent(inout) :: arr(:,:)
    CCTK_REAL :: tmp(ni,nj)
    call copy (tmp, arr, size(tmp))
    arr(:ni, :nj) = tmp(:,:)
    arr(ni+1:, :nj) = 0
    arr(:, nj+1:) = 0
  end subroutine unpack
  
  subroutine copy (a, b, n)
    integer,   intent(in)  :: n
    CCTK_REAL, intent(out) :: a(n)
    CCTK_REAL, intent(in)  :: b(n)
    a = b
  end subroutine copy
  
  subroutine poison (arr)
    CCTK_REAL, intent(out) :: arr(:,:)
    arr = poison_value
  end subroutine poison
  
  subroutine poison_check (arr, name)
    CCTK_REAL,    intent(in) :: arr(:,:)
    character(*), intent(in) :: name
    character*1000 :: msg
!!$    integer        :: i, j
    if (any(arr==poison_value)) then
       write (msg, '("Poison found in ",a)') trim(name)
       call CCTK_WARN (CCTK_WARN_ALERT, msg)
!!$       do j=1,size(arr,2)
!!$          do i=1,size(arr,1)
!!$             print '(2i6)', i,j
!!$          end do
!!$       end do
    end if
  end subroutine poison_check
  
end subroutine qlm_interpolate

```

qlm_killing_normalisation.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



module qlm_killing_normalisation
  use cctk
  use constants
  implicit none
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  private
  public killing_factor
  
contains
  
  subroutine killing_factor (CCTK_ARGUMENTS, hn, theta, factor, nsteps)
    DECLARE_CCTK_ARGUMENTS
    integer,   intent(in)  :: hn
    CCTK_REAL, intent(in)  :: theta
    CCTK_REAL, intent(out) :: factor
    integer,   intent(out) :: nsteps
    
    CCTK_REAL :: lambda0, theta0, phi0
    CCTK_REAL :: lambda1, theta1, phi1
    character :: msg*1000
    
    lambda0 = 0
    theta0  = theta
    phi0    = 0
    phi1    = 2*pi
    call killing_geodesic &
         (CCTK_PASS_FTOF, hn, lambda0, theta0, phi0, phi1, lambda1, theta1, &
         nsteps)
    
    factor = (lambda1 - lambda0) / (2*pi)
    
    if (veryverbose/=0) then
       write (msg, '("Integrated at theta=",g16.6)') theta
       call CCTK_INFO (msg)
       write (msg, '("   Integrated in ",i4," steps")') nsteps
       call CCTK_INFO (msg)
       write (msg, '("   Theta error is ",g16.6)') theta1 - theta0
       call CCTK_INFO (msg)
       write (msg, '("   Normalisation factor is ",g16.6)') factor
       call CCTK_INFO (msg)
    end if
  end subroutine killing_factor
  
  
  
  subroutine killing_geodesic &
       (CCTK_ARGUMENTS, hn, lambda0, theta0, phi0, phi1, lambda1, theta1, nsteps)
    DECLARE_CCTK_ARGUMENTS
    integer,   intent(in)  :: hn
    CCTK_REAL, intent(in)  :: lambda0, theta0, phi0, phi1
    CCTK_REAL, intent(out) :: lambda1, theta1
    integer,   intent(out) :: nsteps
    
    CCTK_REAL :: org_theta, org_phi, del_theta, del_phi
    
    CCTK_REAL :: lambda
    CCTK_REAL :: theta, phi
    CCTK_REAL :: dlambda
    CCTK_REAL :: dtheta, dphi
    CCTK_REAL :: theta2, phi2
    
    integer   :: ierr1, ierr2
    
    org_theta = qlm_origin_theta(hn)
    org_phi   = qlm_origin_phi(hn)
    del_theta = qlm_delta_theta(hn)
    del_phi   = qlm_delta_phi(hn)
    
    nsteps = 0
    lambda = lambda0
    theta  = theta0
    phi    = phi0
    
    dtheta = killing_interp (qlm_xi_t(:,:,hn), &
         org_theta, org_phi, del_theta, del_phi, theta, phi, ierr1)
    dphi   = killing_interp (qlm_xi_p(:,:,hn), &
         org_theta, org_phi, del_theta, del_phi, theta, phi, ierr2)
    
    if (ierr1/=0 .or. ierr2/=0) then
       call CCTK_WARN (2, "Integration path leaves the domain")
       lambda1 = lambda0
       theta1  = theta0
       nsteps  = -1
       return
    end if
    
    if (abs(dphi) < 1.0d-8 .or. abs(dtheta) > abs(dphi)) then
       call CCTK_WARN (2, "Integration path starts out too steep")
       lambda1 = lambda0
       theta1  = theta0
       nsteps  = -1
       return
    end if
    
    dlambda = (qlm_delta_phi(hn) / dphi) / 2
    
    do
       
       dtheta = killing_interp (qlm_xi_t(:,:,hn), &
            org_theta, org_phi, del_theta, del_phi, theta, phi, ierr1)
       dphi   = killing_interp (qlm_xi_p(:,:,hn), &
            org_theta, org_phi, del_theta, del_phi, theta, phi, ierr2)
       
       if (ierr1/=0 .or. ierr2/=0) then
          call CCTK_WARN (2, "Integration path leaves the domain")
          lambda1 = lambda0
          theta1  = theta0
          nsteps  = -1
          return
       end if
       
       theta2 = theta + dlambda * dtheta / 2
       phi2   = phi   + dlambda * dphi   / 2
       
       dtheta = killing_interp (qlm_xi_t(:,:,hn), &
            org_theta, org_phi, del_theta, del_phi, theta2, phi2, ierr1)
       dphi   = killing_interp (qlm_xi_p(:,:,hn), &
            org_theta, org_phi, del_theta, del_phi, theta2, phi2, ierr2)
       
       if (ierr1/=0 .or. ierr2/=0) then
          call CCTK_WARN (2, "Integration path leaves the domain")
          lambda1 = lambda0
          theta1  = theta0
          nsteps  = -1
          return
       end if
       
       if (dphi<=0) then
          call CCTK_WARN (2, "Integration path does not enclose the pole")
          lambda1 = lambda0
          theta1  = theta0
          nsteps  = -1
          return
       end if
       
       theta2 = theta + dlambda * dtheta
       phi2   = phi   + dlambda * dphi
       
       if (phi2 >= phi1) exit
       
       if (nsteps > 100000) then
          call CCTK_WARN (2, "Integration takes too many steps")
          lambda1 = lambda0
          theta1  = theta0
          nsteps  = -1
          return
          exit
       end if
       
       nsteps = nsteps + 1
       lambda = lambda + dlambda
       theta  = theta2
       phi    = phi2
       
    end do
    
    dlambda = (phi1 - phi) / dphi
    
    nsteps = nsteps + 1
    lambda = lambda + dlambda
    theta  = theta  + dlambda * dtheta
    phi    = phi    + dlambda * dphi
    
    lambda1 = lambda
    theta1  = theta
    
  end subroutine killing_geodesic
  
  
  
  function killing_interp &
       (array, origin_x1, origin_x2, delta_x1, delta_x2, x1, x2, ierr)
    CCTK_REAL :: killing_interp
    CCTK_REAL, intent(in)  :: array(:,:)
    CCTK_REAL, intent(in)  :: origin_x1, origin_x2
    CCTK_REAL, intent(in)  :: delta_x1, delta_x2
    CCTK_REAL, intent(in)  :: x1, x2
    integer,   intent(out) :: ierr
    CCTK_REAL, parameter :: eps = 1.0d-10
    CCTK_REAL :: xx1, xx2
    CCTK_REAL :: dx1, dx2
    CCTK_REAL :: f1a, f1b, f1c
    CCTK_REAL :: f2a, f2b, f2c
    CCTK_REAL :: interp2a, interp2b, interp2c
    integer   :: i, j
    xx1 = x1
    xx2 = x2
    i = nint((xx1 - origin_x1) / delta_x1) + 1
    j = nint((xx2 - origin_x2) / delta_x2) + 1
    i = max(2, min(size(array,1)-1, i))
    if (j>size(array,2)-1) then
       ! periodicity in phi-direction
       xx2 = xx2 - (size(array,2)-2) * delta_x2
       j = j - size(array,2)-2
    end if
    j = max(2, min(size(array,2)-1, j))
    dx1 = xx1 - (origin_x1 + (i-1) * delta_x1)
    dx2 = xx2 - (origin_x2 + (j-1) * delta_x2)
    if (abs(dx1)>(1+eps)*delta_x1/2 .or. abs(dx2)>(1+eps)*delta_x2/2) then
       call CCTK_WARN (2, "interpolating out of bounds")
       killing_interp = 0
       ierr = 1
       return
    end if
    f1a =            (-dx1) * (1-dx1) / (  2  *   1 )
    f1b = (-1-dx1) *          (1-dx1) / (  1  * (-1))
    f1c = (-1-dx1) * (-dx1)           / ((-1) * (-2))
    f2a =            (-dx2) * (1-dx2) / (  2  *   1 )
    f2b = (-1-dx2) *          (1-dx2) / (  1  * (-1))
    f2c = (-1-dx2) * (-dx2)           / ((-1) * (-2))
    interp2a = f1a * array(i-1,j-1) + f1b * array(i,j-1) + f1c * array(i+1,j-1)
    interp2b = f1a * array(i-1,j  ) + f1b * array(i,j  ) + f1c * array(i+1,j  )
    interp2c = f1a * array(i-1,j+1) + f1b * array(i,j+1) + f1c * array(i+1,j+1)
    killing_interp = f2a * interp2a + f2b * interp2b + f2c * interp2c
    ierr = 0
  end function killing_interp
  
end module qlm_killing_normalisation

```

qlm_weyl_scalars.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_calc_weyl_scalars (CCTK_ARGUMENTS, hn)
  use adm_metric_simple
  use cctk
  use constants
  use qlm_boundary
  use qlm_derivs
  use qlm_variables
  use ricci
  use ricci4
  use tensor
  use tensor4
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL, parameter :: two=2, four=4
  CCTK_REAL    :: gg(3,3), dgg(3,3,3), ddgg(3,3,3,3), gg_dot(3,3), gg_dot2(3,3), dgg_dot(3,3,3)
  CCTK_REAL    :: kk(3,3), dkk(3,3,3), kk_dot(3,3)
  CCTK_REAL    :: tt(3,3)
  CCTK_REAL    :: dtg, gu(3,3), dgu(3,3,3), gamma(3,3,3), dgamma(3,3,3,3), ri(3,3), rsc
  CCTK_REAL    :: g4(0:3,0:3), dg4(0:3,0:3,0:3), ddg4(0:3,0:3,0:3,0:3)
  CCTK_REAL    :: gu4(0:3,0:3), dgu4(0:3,0:3,0:3)
  CCTK_REAL    :: gamma4(0:3,0:3,0:3), dgamma4(0:3,0:3,0:3,0:3)
  CCTK_REAL    :: ri4(0:3,0:3), rsc4
  CCTK_REAL    :: rm4(0:3,0:3,0:3,0:3), we4(0:3,0:3,0:3,0:3)
  CCTK_REAL    :: ll(0:3), nn(0:3)
  CCTK_COMPLEX :: mm(0:3)
  CCTK_REAL    :: ss(0:3)
  CCTK_REAL    :: nabla_ll(0:3,0:3), nabla_nn(0:3,0:3)
  CCTK_REAL    :: nabla_ss(0:3,0:3)
  CCTK_REAL    :: trkAH, kk_kk, tmpR
  
  integer      :: i, j
  integer      :: a, b, c, d
  CCTK_REAL    :: theta, phi
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Calculating Weyl scalars")
  end if
  
  ! Calculate the coordinates
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        theta = qlm_origin_theta(hn) + (i-1)*qlm_delta_theta(hn)
        phi   = qlm_origin_phi(hn)   + (j-1)*qlm_delta_phi(hn)
        
        ! Get the stuff from the arrays
        gg(1,1) = qlm_gxx(i,j)
        gg(1,2) = qlm_gxy(i,j)
        gg(1,3) = qlm_gxz(i,j)
        gg(2,2) = qlm_gyy(i,j)
        gg(2,3) = qlm_gyz(i,j)
        gg(3,3) = qlm_gzz(i,j)
        gg(2,1) = gg(1,2)
        gg(3,1) = gg(1,3)
        gg(3,2) = gg(2,3)
        
        dgg(1,1,1) = qlm_dgxxx(i,j)
        dgg(1,2,1) = qlm_dgxyx(i,j)
        dgg(1,3,1) = qlm_dgxzx(i,j)
        dgg(2,2,1) = qlm_dgyyx(i,j)
        dgg(2,3,1) = qlm_dgyzx(i,j)
        dgg(3,3,1) = qlm_dgzzx(i,j)
        dgg(1,1,2) = qlm_dgxxy(i,j)
        dgg(1,2,2) = qlm_dgxyy(i,j)
        dgg(1,3,2) = qlm_dgxzy(i,j)
        dgg(2,2,2) = qlm_dgyyy(i,j)
        dgg(2,3,2) = qlm_dgyzy(i,j)
        dgg(3,3,2) = qlm_dgzzy(i,j)
        dgg(1,1,3) = qlm_dgxxz(i,j)
        dgg(1,2,3) = qlm_dgxyz(i,j)
        dgg(1,3,3) = qlm_dgxzz(i,j)
        dgg(2,2,3) = qlm_dgyyz(i,j)
        dgg(2,3,3) = qlm_dgyzz(i,j)
        dgg(3,3,3) = qlm_dgzzz(i,j)
        dgg(2,1,:) = dgg(1,2,:)
        dgg(3,1,:) = dgg(1,3,:)
        dgg(3,2,:) = dgg(2,3,:)
        
        ddgg(1,1,1,1) = qlm_ddgxxxx(i,j)
        ddgg(1,2,1,1) = qlm_ddgxyxx(i,j)
        ddgg(1,3,1,1) = qlm_ddgxzxx(i,j)
        ddgg(2,2,1,1) = qlm_ddgyyxx(i,j)
        ddgg(2,3,1,1) = qlm_ddgyzxx(i,j)
        ddgg(3,3,1,1) = qlm_ddgzzxx(i,j)
        ddgg(1,1,1,2) = qlm_ddgxxxy(i,j)
        ddgg(1,2,1,2) = qlm_ddgxyxy(i,j)
        ddgg(1,3,1,2) = qlm_ddgxzxy(i,j)
        ddgg(2,2,1,2) = qlm_ddgyyxy(i,j)
        ddgg(2,3,1,2) = qlm_ddgyzxy(i,j)
        ddgg(3,3,1,2) = qlm_ddgzzxy(i,j)
        ddgg(1,1,1,3) = qlm_ddgxxxz(i,j)
        ddgg(1,2,1,3) = qlm_ddgxyxz(i,j)
        ddgg(1,3,1,3) = qlm_ddgxzxz(i,j)
        ddgg(2,2,1,3) = qlm_ddgyyxz(i,j)
        ddgg(2,3,1,3) = qlm_ddgyzxz(i,j)
        ddgg(3,3,1,3) = qlm_ddgzzxz(i,j)
        ddgg(1,1,2,2) = qlm_ddgxxyy(i,j)
        ddgg(1,2,2,2) = qlm_ddgxyyy(i,j)
        ddgg(1,3,2,2) = qlm_ddgxzyy(i,j)
        ddgg(2,2,2,2) = qlm_ddgyyyy(i,j)
        ddgg(2,3,2,2) = qlm_ddgyzyy(i,j)
        ddgg(3,3,2,2) = qlm_ddgzzyy(i,j)
        ddgg(1,1,2,3) = qlm_ddgxxyz(i,j)
        ddgg(1,2,2,3) = qlm_ddgxyyz(i,j)
        ddgg(1,3,2,3) = qlm_ddgxzyz(i,j)
        ddgg(2,2,2,3) = qlm_ddgyyyz(i,j)
        ddgg(2,3,2,3) = qlm_ddgyzyz(i,j)
        ddgg(3,3,2,3) = qlm_ddgzzyz(i,j)
        ddgg(1,1,3,3) = qlm_ddgxxzz(i,j)
        ddgg(1,2,3,3) = qlm_ddgxyzz(i,j)
        ddgg(1,3,3,3) = qlm_ddgxzzz(i,j)
        ddgg(2,2,3,3) = qlm_ddgyyzz(i,j)
        ddgg(2,3,3,3) = qlm_ddgyzzz(i,j)
        ddgg(3,3,3,3) = qlm_ddgzzzz(i,j)
        ddgg(2,1,:,:) = ddgg(1,2,:,:)
        ddgg(3,1,:,:) = ddgg(1,3,:,:)
        ddgg(3,2,:,:) = ddgg(2,3,:,:)
        ddgg(:,:,2,1) = ddgg(:,:,1,2)
        ddgg(:,:,3,1) = ddgg(:,:,1,3)
        ddgg(:,:,3,2) = ddgg(:,:,2,3)
        
        kk(1,1) = qlm_kxx(i,j)
        kk(1,2) = qlm_kxy(i,j)
        kk(1,3) = qlm_kxz(i,j)
        kk(2,2) = qlm_kyy(i,j)
        kk(2,3) = qlm_kyz(i,j)
        kk(3,3) = qlm_kzz(i,j)
        kk(2,1) = kk(1,2)
        kk(3,1) = kk(1,3)
        kk(3,2) = kk(2,3)
        
        dkk(1,1,1) = qlm_dkxxx(i,j)
        dkk(1,2,1) = qlm_dkxyx(i,j)
        dkk(1,3,1) = qlm_dkxzx(i,j)
        dkk(2,2,1) = qlm_dkyyx(i,j)
        dkk(2,3,1) = qlm_dkyzx(i,j)
        dkk(3,3,1) = qlm_dkzzx(i,j)
        dkk(1,1,2) = qlm_dkxxy(i,j)
        dkk(1,2,2) = qlm_dkxyy(i,j)
        dkk(1,3,2) = qlm_dkxzy(i,j)
        dkk(2,2,2) = qlm_dkyyy(i,j)
        dkk(2,3,2) = qlm_dkyzy(i,j)
        dkk(3,3,2) = qlm_dkzzy(i,j)
        dkk(1,1,3) = qlm_dkxxz(i,j)
        dkk(1,2,3) = qlm_dkxyz(i,j)
        dkk(1,3,3) = qlm_dkxzz(i,j)
        dkk(2,2,3) = qlm_dkyyz(i,j)
        dkk(2,3,3) = qlm_dkyzz(i,j)
        dkk(3,3,3) = qlm_dkzzz(i,j)
        dkk(2,1,:) = dkk(1,2,:)
        dkk(3,1,:) = dkk(1,3,:)
        dkk(3,2,:) = dkk(2,3,:)
        
        tt(1,1) = qlm_txx(i,j)
        tt(1,2) = qlm_txy(i,j)
        tt(1,3) = qlm_txz(i,j)
        tt(2,2) = qlm_tyy(i,j)
        tt(2,3) = qlm_tyz(i,j)
        tt(3,3) = qlm_tzz(i,j)
        tt(2,1) = tt(1,2)
        tt(3,1) = tt(1,3)
        tt(3,2) = tt(2,3)
        
        ll(0) = qlm_l0(i,j,hn)
        ll(1) = qlm_l1(i,j,hn)
        ll(2) = qlm_l2(i,j,hn)
        ll(3) = qlm_l3(i,j,hn)
        
        nn(0) = qlm_n0(i,j,hn)
        nn(1) = qlm_n1(i,j,hn)
        nn(2) = qlm_n2(i,j,hn)
        nn(3) = qlm_n3(i,j,hn)
        
        mm(0) = qlm_m0(i,j,hn)
        mm(1) = qlm_m1(i,j,hn)
        mm(2) = qlm_m2(i,j,hn)
        mm(3) = qlm_m3(i,j,hn)
        
        ss = (ll - nn) / sqrt(two)
        
        nabla_ll = qlm_tetrad_derivs(i,j)%nabla_ll
        nabla_nn = qlm_tetrad_derivs(i,j)%nabla_nn
        
        nabla_ss = (nabla_ll - nabla_nn) / sqrt(two)
        
        
        
        ! Calculate 4-metric
        call calc_det (gg, dtg)
        call calc_inv (gg, dtg, gu)
        call calc_invderiv (gu, dgg, dgu)
        call calc_connections (gu, dgg, gamma)
        call calc_connectionderivs (gu, dgg, dgu, ddgg, dgamma)
        call calc_ricci (gamma, dgamma, ri)
        call calc_trace (gu, ri, rsc)
        
        call calc_3metricdot_simple (kk, gg_dot)
        call calc_3metricderivdot_simple (dkk, dgg_dot)
        call calc_extcurvdot_simple (gg,gu,ri, kk, tt, kk_dot)
        call calc_3metricdot2_simple (kk_dot, gg_dot2)
        
        call calc_4metricderivs2_simple (gg, dgg, &
             ddgg, gg_dot, gg_dot2, dgg_dot, g4,dg4,ddg4)
        call calc_4inv (g4, gu4)
        call calc_4invderiv (gu4, dg4, dgu4)
        call calc_4connections (gu4,dg4, gamma4)
        call calc_4connectionderivs (gu4, dg4, dgu4, ddg4, dgamma4)
        call calc_4ricci (gamma4, dgamma4, ri4)
        call calc_4riemann (g4, gamma4, dgamma4, rm4)
        call calc_4trace (ri4, gu4, rsc4)
        call calc_4weyl (g4, rm4, ri4, rsc4, we4)
        
        ! debugging       
!        qlm_rsc4(i,j,hn) = rsc4 
        
        qlm_psi0(i,j,hn) = 0     ! transverse radiation along n
        qlm_psi1(i,j,hn) = 0     ! longitudinal radiation along n
        qlm_psi2(i,j,hn) = 0     ! Coulomb field and spin
        qlm_psi3(i,j,hn) = 0     ! longitudinal radiation along l
        qlm_psi4(i,j,hn) = 0     ! transverse radiation along l
        
        do a=0,3
           do b=0,3
              do c=0,3
                 do d=0,3
                    qlm_psi0(i,j,hn) = qlm_psi0(i,j,hn) + we4(a,b,c,d) * ll(a) * mm(b) * ll(c) * mm(d)
                    qlm_psi1(i,j,hn) = qlm_psi1(i,j,hn) + we4(a,b,c,d) * ll(a) * mm(b) * ll(c) * nn(d)
                    qlm_psi2(i,j,hn) = qlm_psi2(i,j,hn) + we4(a,b,c,d) * ll(a) * mm(b) * conjg(mm(c)) * nn(d)
                    qlm_psi3(i,j,hn) = qlm_psi3(i,j,hn) + we4(a,b,c,d) * ll(a) * nn(b) * conjg(mm(c)) * nn(d)
                    qlm_psi4(i,j,hn) = qlm_psi4(i,j,hn) + we4(a,b,c,d) * conjg(mm(a)) * nn(b) * conjg(mm(c)) * nn(d)
                 end do
              end do
           end do
        end do
        
        ! gr-qc/0104063, (3.3)
        qlm_i(i,j,hn) = + 3 * qlm_psi2(i,j,hn)**2 &
             &         - 4 * qlm_psi1(i,j,hn) * qlm_psi3(i,j,hn) &
             &         +     qlm_psi0(i,j,hn) * qlm_psi4(i,j,hn)
        qlm_j(i,j,hn) = -     qlm_psi2(i,j,hn)**3 &
             &         +     qlm_psi0(i,j,hn) * qlm_psi2(i,j,hn) * qlm_psi4(i,j,hn) &
             &         + 2 * qlm_psi1(i,j,hn) * qlm_psi2(i,j,hn) * qlm_psi3(i,j,hn) &
             &         -     qlm_psi1(i,j,hn)**2 * qlm_psi4(i,j,hn) &
             &         -     qlm_psi0(i,j,hn) * qlm_psi3(i,j,hn)**2
        
        ! gr-qc/0104063, (3.1)
        qlm_s(i,j,hn) = 27 * qlm_j(i,j,hn)**2 / qlm_i(i,j,hn)**3
        qlm_sdiff(i,j,hn) = (27 * qlm_j(i,j,hn)**2 - qlm_i(i,j,hn)**3) / sqrt((abs2(qlm_psi0(i,j,hn)) + abs2(qlm_psi1(i,j,hn)) + abs2(qlm_psi2(i,j,hn)) + abs2(qlm_psi3(i,j,hn)) + abs2(qlm_psi4(i,j,hn))) / 5)**3
        
        qlm_phi00(i,j,hn) = 0
        qlm_phi11(i,j,hn) = 0
        qlm_phi01(i,j,hn) = 0
        qlm_phi12(i,j,hn) = 0
        qlm_phi10(i,j,hn) = 0
        qlm_phi21(i,j,hn) = 0
        qlm_phi02(i,j,hn) = 0
        qlm_phi22(i,j,hn) = 0
        qlm_phi20(i,j,hn) = 0
        
        do a=0,3
           do b=0,3
              
              qlm_phi00(i,j,hn) = qlm_phi00(i,j,hn) - 1/two * ri4(a,b) * ll(a) * ll(b)
              qlm_phi11(i,j,hn) = qlm_phi11(i,j,hn) - 1/two * ri4(a,b) * (ll(a) * nn(b) + mm(a) * conjg(mm(b))) / 2
              qlm_phi01(i,j,hn) = qlm_phi01(i,j,hn) - 1/two * ri4(a,b) * ll(a) * mm(b)
              qlm_phi12(i,j,hn) = qlm_phi12(i,j,hn) - 1/two * ri4(a,b) * nn(a) * mm(b)
              qlm_phi10(i,j,hn) = qlm_phi10(i,j,hn) - 1/two * ri4(a,b) * ll(a) * conjg(mm(b))
              qlm_phi21(i,j,hn) = qlm_phi21(i,j,hn) - 1/two * ri4(a,b) * nn(a) * conjg(mm(b))
              qlm_phi02(i,j,hn) = qlm_phi02(i,j,hn) - 1/two * ri4(a,b) * mm(a) * mm(b)
              qlm_phi22(i,j,hn) = qlm_phi22(i,j,hn) - 1/two * ri4(a,b) * nn(a) * nn(b)
              qlm_phi20(i,j,hn) = qlm_phi20(i,j,hn) - 1/two * ri4(a,b) * conjg(mm(a)) * conjg(mm(b))
              
           end do
        end do
        
        qlm_lambda(i,j,hn) = rsc4 / 24
        
        qlm_lie_n_theta_l(i,j,hn) = &
             & + 2 * real (qlm_npsigma(i,j,hn) * qlm_nplambda(i,j,hn)) &
             & + 2 * real (qlm_psi2(i,j,hn)) &
             & + 4 * qlm_lambda(i,j,hn)
        
        

        trkAH = 0
        do a=1,3
           do b=1,3
              trkAH = trkAH + (gu(a,b) - ss(a) * ss(b)) * nabla_ss(a,b) 
           end do
        end do
        
        kk_kk = 0
        do a=1,3
           do b=1,3
              do c=1,3
                 do d=1,3
                    kk_kk = kk_kk + &
                         (gu(a,c) - ss(a) * ss(c)) * nabla_ss(a,b) * &
                         (gu(b,d) - ss(b) * ss(d)) * nabla_ss(c,d)
                 end do
              end do
           end do
        end do
        
        tmpR = 0
        do a=1,3
           do b=1,3
              tmpR = tmpR + ri(a,b) * ss(a) * ss(b)
           end do
        end do
        
        qlm_rsc(i,j,hn) = rsc - 2*tmpR + trkAH**2 - kk_kk
        
     end do
  end do
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_psi0(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_psi1(:,:,hn), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_psi2(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_psi3(:,:,hn), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_psi4(:,:,hn), +1)
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_i(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_j(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_s(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_sdiff(:,:,hn), +1)
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_phi00(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_phi11(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_phi01(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_phi12(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_phi10(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_phi21(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_phi02(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_phi22(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_phi20(:,:,hn), +1)
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_lambda(:,:,hn), +1)
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_lie_n_theta_l(:,:,hn), +1)
 
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_rsc(:,:,hn), +1)
  
end subroutine qlm_calc_weyl_scalars

```

qlm_variables.F90:
```
#include "cctk.h"

module qlm_variables
  use classify
  implicit none
  public
  save
  CCTK_REAL, allocatable, dimension(:,:) :: &
       qlm_gxx, qlm_gxy, qlm_gxz, qlm_gyy, qlm_gyz, qlm_gzz, &
       qlm_dgxxx, qlm_dgxyx, qlm_dgxzx, qlm_dgyyx, qlm_dgyzx, qlm_dgzzx, &
       qlm_dgxxy, qlm_dgxyy, qlm_dgxzy, qlm_dgyyy, qlm_dgyzy, qlm_dgzzy, &
       qlm_dgxxz, qlm_dgxyz, qlm_dgxzz, qlm_dgyyz, qlm_dgyzz, qlm_dgzzz, &
       qlm_ddgxxxx, qlm_ddgxyxx, qlm_ddgxzxx, qlm_ddgyyxx, qlm_ddgyzxx, qlm_ddgzzxx, &
       qlm_ddgxxxy, qlm_ddgxyxy, qlm_ddgxzxy, qlm_ddgyyxy, qlm_ddgyzxy, qlm_ddgzzxy, &
       qlm_ddgxxxz, qlm_ddgxyxz, qlm_ddgxzxz, qlm_ddgyyxz, qlm_ddgyzxz, qlm_ddgzzxz, &
       qlm_ddgxxyy, qlm_ddgxyyy, qlm_ddgxzyy, qlm_ddgyyyy, qlm_ddgyzyy, qlm_ddgzzyy, &
       qlm_ddgxxyz, qlm_ddgxyyz, qlm_ddgxzyz, qlm_ddgyyyz, qlm_ddgyzyz, qlm_ddgzzyz, &
       qlm_ddgxxzz, qlm_ddgxyzz, qlm_ddgxzzz, qlm_ddgyyzz, qlm_ddgyzzz, qlm_ddgzzzz, &
       qlm_kxx, qlm_kxy, qlm_kxz, qlm_kyy, qlm_kyz, qlm_kzz, &
       qlm_dkxxx, qlm_dkxyx, qlm_dkxzx, qlm_dkyyx, qlm_dkyzx, qlm_dkzzx, &
       qlm_dkxxy, qlm_dkxyy, qlm_dkxzy, qlm_dkyyy, qlm_dkyzy, qlm_dkzzy, &
       qlm_dkxxz, qlm_dkxyz, qlm_dkxzz, qlm_dkyyz, qlm_dkyzz, qlm_dkzzz, &
       qlm_alpha, &
       qlm_betax, qlm_betay, qlm_betaz, &
       qlm_ttt, &
       qlm_ttx, qlm_tty, qlm_ttz, &
       qlm_txx, qlm_txy, qlm_txz, qlm_tyy, qlm_tyz, qlm_tzz
  CCTK_REAL, allocatable, dimension(:,:) :: &
       qlm_dqttt, qlm_dqtpt, qlm_dqppt, qlm_dqttp, qlm_dqtpp, qlm_dqppp
  
  CCTK_REAL, allocatable, dimension(:,:) :: &
       qlm_spin_density
  
  type tetrad_derivs
     ! nabla_ll(a,b) = D_b l_a
     CCTK_REAL    :: nabla_ll(0:3,0:3)
     CCTK_REAL    :: nabla_nn(0:3,0:3)
     CCTK_COMPLEX :: nabla_mm(0:3,0:3)
  end type tetrad_derivs
  type(tetrad_derivs), allocatable, dimension(:,:) :: qlm_tetrad_derivs
  
contains
  
  subroutine allocate_variables(ntheta, nphi)
    integer,   intent(in) :: ntheta, nphi
    CCTK_REAL, parameter  :: zero = 0
    integer,   parameter  :: rk = kind(zero)
    type(tetrad_derivs)   :: tetrad_derivs_nan
    
    allocate(qlm_gxx(ntheta,nphi))
    allocate(qlm_gxy(ntheta,nphi))
    allocate(qlm_gxz(ntheta,nphi))
    allocate(qlm_gyy(ntheta,nphi))
    allocate(qlm_gyz(ntheta,nphi))
    allocate(qlm_gzz(ntheta,nphi))
    allocate(qlm_dgxxx(ntheta,nphi))
    allocate(qlm_dgxyx(ntheta,nphi))
    allocate(qlm_dgxzx(ntheta,nphi))
    allocate(qlm_dgyyx(ntheta,nphi))
    allocate(qlm_dgyzx(ntheta,nphi))
    allocate(qlm_dgzzx(ntheta,nphi))
    allocate(qlm_dgxxy(ntheta,nphi))
    allocate(qlm_dgxyy(ntheta,nphi))
    allocate(qlm_dgxzy(ntheta,nphi))
    allocate(qlm_dgyyy(ntheta,nphi))
    allocate(qlm_dgyzy(ntheta,nphi))
    allocate(qlm_dgzzy(ntheta,nphi))
    allocate(qlm_dgxxz(ntheta,nphi))
    allocate(qlm_dgxyz(ntheta,nphi))
    allocate(qlm_dgxzz(ntheta,nphi))
    allocate(qlm_dgyyz(ntheta,nphi))
    allocate(qlm_dgyzz(ntheta,nphi))
    allocate(qlm_dgzzz(ntheta,nphi))
    allocate(qlm_ddgxxxx(ntheta,nphi))
    allocate(qlm_ddgxyxx(ntheta,nphi))
    allocate(qlm_ddgxzxx(ntheta,nphi))
    allocate(qlm_ddgyyxx(ntheta,nphi))
    allocate(qlm_ddgyzxx(ntheta,nphi))
    allocate(qlm_ddgzzxx(ntheta,nphi))
    allocate(qlm_ddgxxxy(ntheta,nphi))
    allocate(qlm_ddgxyxy(ntheta,nphi))
    allocate(qlm_ddgxzxy(ntheta,nphi))
    allocate(qlm_ddgyyxy(ntheta,nphi))
    allocate(qlm_ddgyzxy(ntheta,nphi))
    allocate(qlm_ddgzzxy(ntheta,nphi))
    allocate(qlm_ddgxxxz(ntheta,nphi))
    allocate(qlm_ddgxyxz(ntheta,nphi))
    allocate(qlm_ddgxzxz(ntheta,nphi))
    allocate(qlm_ddgyyxz(ntheta,nphi))
    allocate(qlm_ddgyzxz(ntheta,nphi))
    allocate(qlm_ddgzzxz(ntheta,nphi))
    allocate(qlm_ddgxxyy(ntheta,nphi))
    allocate(qlm_ddgxyyy(ntheta,nphi))
    allocate(qlm_ddgxzyy(ntheta,nphi))
    allocate(qlm_ddgyyyy(ntheta,nphi))
    allocate(qlm_ddgyzyy(ntheta,nphi))
    allocate(qlm_ddgzzyy(ntheta,nphi))
    allocate(qlm_ddgxxyz(ntheta,nphi))
    allocate(qlm_ddgxyyz(ntheta,nphi))
    allocate(qlm_ddgxzyz(ntheta,nphi))
    allocate(qlm_ddgyyyz(ntheta,nphi))
    allocate(qlm_ddgyzyz(ntheta,nphi))
    allocate(qlm_ddgzzyz(ntheta,nphi))
    allocate(qlm_ddgxxzz(ntheta,nphi))
    allocate(qlm_ddgxyzz(ntheta,nphi))
    allocate(qlm_ddgxzzz(ntheta,nphi))
    allocate(qlm_ddgyyzz(ntheta,nphi))
    allocate(qlm_ddgyzzz(ntheta,nphi))
    allocate(qlm_ddgzzzz(ntheta,nphi))
    allocate(qlm_kxx(ntheta,nphi))
    allocate(qlm_kxy(ntheta,nphi))
    allocate(qlm_kxz(ntheta,nphi))
    allocate(qlm_kyy(ntheta,nphi))
    allocate(qlm_kyz(ntheta,nphi))
    allocate(qlm_kzz(ntheta,nphi))
    allocate(qlm_dkxxx(ntheta,nphi))
    allocate(qlm_dkxyx(ntheta,nphi))
    allocate(qlm_dkxzx(ntheta,nphi))
    allocate(qlm_dkyyx(ntheta,nphi))
    allocate(qlm_dkyzx(ntheta,nphi))
    allocate(qlm_dkzzx(ntheta,nphi))
    allocate(qlm_dkxxy(ntheta,nphi))
    allocate(qlm_dkxyy(ntheta,nphi))
    allocate(qlm_dkxzy(ntheta,nphi))
    allocate(qlm_dkyyy(ntheta,nphi))
    allocate(qlm_dkyzy(ntheta,nphi))
    allocate(qlm_dkzzy(ntheta,nphi))
    allocate(qlm_dkxxz(ntheta,nphi))
    allocate(qlm_dkxyz(ntheta,nphi))
    allocate(qlm_dkxzz(ntheta,nphi))
    allocate(qlm_dkyyz(ntheta,nphi))
    allocate(qlm_dkyzz(ntheta,nphi))
    allocate(qlm_dkzzz(ntheta,nphi))
    allocate(qlm_alpha(ntheta,nphi))
    allocate(qlm_betax(ntheta,nphi))
    allocate(qlm_betay(ntheta,nphi))
    allocate(qlm_betaz(ntheta,nphi))
    allocate(qlm_ttt(ntheta,nphi))
    allocate(qlm_ttx(ntheta,nphi))
    allocate(qlm_tty(ntheta,nphi))
    allocate(qlm_ttz(ntheta,nphi))
    allocate(qlm_txx(ntheta,nphi))
    allocate(qlm_txy(ntheta,nphi))
    allocate(qlm_txz(ntheta,nphi))
    allocate(qlm_tyy(ntheta,nphi))
    allocate(qlm_tyz(ntheta,nphi))
    allocate(qlm_tzz(ntheta,nphi))
    
    allocate(qlm_dqttt(ntheta,nphi))
    allocate(qlm_dqtpt(ntheta,nphi))
    allocate(qlm_dqppt(ntheta,nphi))
    allocate(qlm_dqttp(ntheta,nphi))
    allocate(qlm_dqtpp(ntheta,nphi))
    allocate(qlm_dqppp(ntheta,nphi))
    
    allocate(qlm_tetrad_derivs(ntheta,nphi))
    
    allocate(qlm_spin_density(ntheta,nphi))
    
    qlm_gxx = TAT_nan()
    qlm_gxy = TAT_nan()
    qlm_gxz = TAT_nan()
    qlm_gyy = TAT_nan()
    qlm_gyz = TAT_nan()
    qlm_gzz = TAT_nan()
    qlm_dgxxx = TAT_nan()
    qlm_dgxyx = TAT_nan()
    qlm_dgxzx = TAT_nan()
    qlm_dgyyx = TAT_nan()
    qlm_dgyzx = TAT_nan()
    qlm_dgzzx = TAT_nan()
    qlm_dgxxy = TAT_nan()
    qlm_dgxyy = TAT_nan()
    qlm_dgxzy = TAT_nan()
    qlm_dgyyy = TAT_nan()
    qlm_dgyzy = TAT_nan()
    qlm_dgzzy = TAT_nan()
    qlm_dgxxz = TAT_nan()
    qlm_dgxyz = TAT_nan()
    qlm_dgxzz = TAT_nan()
    qlm_dgyyz = TAT_nan()
    qlm_dgyzz = TAT_nan()
    qlm_dgzzz = TAT_nan()
    qlm_ddgxxxx = TAT_nan()
    qlm_ddgxyxx = TAT_nan()
    qlm_ddgxzxx = TAT_nan()
    qlm_ddgyyxx = TAT_nan()
    qlm_ddgyzxx = TAT_nan()
    qlm_ddgzzxx = TAT_nan()
    qlm_ddgxxxy = TAT_nan()
    qlm_ddgxyxy = TAT_nan()
    qlm_ddgxzxy = TAT_nan()
    qlm_ddgyyxy = TAT_nan()
    qlm_ddgyzxy = TAT_nan()
    qlm_ddgzzxy = TAT_nan()
    qlm_ddgxxxz = TAT_nan()
    qlm_ddgxyxz = TAT_nan()
    qlm_ddgxzxz = TAT_nan()
    qlm_ddgyyxz = TAT_nan()
    qlm_ddgyzxz = TAT_nan()
    qlm_ddgzzxz = TAT_nan()
    qlm_ddgxxyy = TAT_nan()
    qlm_ddgxyyy = TAT_nan()
    qlm_ddgxzyy = TAT_nan()
    qlm_ddgyyyy = TAT_nan()
    qlm_ddgyzyy = TAT_nan()
    qlm_ddgzzyy = TAT_nan()
    qlm_ddgxxyz = TAT_nan()
    qlm_ddgxyyz = TAT_nan()
    qlm_ddgxzyz = TAT_nan()
    qlm_ddgyyyz = TAT_nan()
    qlm_ddgyzyz = TAT_nan()
    qlm_ddgzzyz = TAT_nan()
    qlm_ddgxxzz = TAT_nan()
    qlm_ddgxyzz = TAT_nan()
    qlm_ddgxzzz = TAT_nan()
    qlm_ddgyyzz = TAT_nan()
    qlm_ddgyzzz = TAT_nan()
    qlm_ddgzzzz = TAT_nan()
    qlm_kxx = TAT_nan()
    qlm_kxy = TAT_nan()
    qlm_kxz = TAT_nan()
    qlm_kyy = TAT_nan()
    qlm_kyz = TAT_nan()
    qlm_kzz = TAT_nan()
    qlm_dkxxx = TAT_nan()
    qlm_dkxyx = TAT_nan()
    qlm_dkxzx = TAT_nan()
    qlm_dkyyx = TAT_nan()
    qlm_dkyzx = TAT_nan()
    qlm_dkzzx = TAT_nan()
    qlm_dkxxy = TAT_nan()
    qlm_dkxyy = TAT_nan()
    qlm_dkxzy = TAT_nan()
    qlm_dkyyy = TAT_nan()
    qlm_dkyzy = TAT_nan()
    qlm_dkzzy = TAT_nan()
    qlm_dkxxz = TAT_nan()
    qlm_dkxyz = TAT_nan()
    qlm_dkxzz = TAT_nan()
    qlm_dkyyz = TAT_nan()
    qlm_dkyzz = TAT_nan()
    qlm_dkzzz = TAT_nan()
    qlm_alpha = TAT_nan()
    qlm_betax = TAT_nan()
    qlm_betay = TAT_nan()
    qlm_betaz = TAT_nan()
    qlm_ttt = TAT_nan()
    qlm_ttx = TAT_nan()
    qlm_tty = TAT_nan()
    qlm_ttz = TAT_nan()
    qlm_txx = TAT_nan()
    qlm_txy = TAT_nan()
    qlm_txz = TAT_nan()
    qlm_tyy = TAT_nan()
    qlm_tyz = TAT_nan()
    qlm_tzz = TAT_nan()
    
    qlm_dqttt = TAT_nan()
    qlm_dqtpt = TAT_nan()
    qlm_dqppt = TAT_nan()
    qlm_dqttp = TAT_nan()
    qlm_dqtpp = TAT_nan()
    qlm_dqppp = TAT_nan()
    
    tetrad_derivs_nan%nabla_ll = TAT_nan()
    tetrad_derivs_nan%nabla_nn = TAT_nan()
    tetrad_derivs_nan%nabla_mm = cmplx(TAT_nan(),TAT_nan(),rk)
    qlm_tetrad_derivs = tetrad_derivs_nan

    qlm_spin_density = TAT_nan()
  end subroutine allocate_variables

  subroutine deallocate_variables
    deallocate(qlm_gxx)
    deallocate(qlm_gxy)
    deallocate(qlm_gxz)
    deallocate(qlm_gyy)
    deallocate(qlm_gyz)
    deallocate(qlm_gzz)
    deallocate(qlm_dgxxx)
    deallocate(qlm_dgxyx)
    deallocate(qlm_dgxzx)
    deallocate(qlm_dgyyx)
    deallocate(qlm_dgyzx)
    deallocate(qlm_dgzzx)
    deallocate(qlm_dgxxy)
    deallocate(qlm_dgxyy)
    deallocate(qlm_dgxzy)
    deallocate(qlm_dgyyy)
    deallocate(qlm_dgyzy)
    deallocate(qlm_dgzzy)
    deallocate(qlm_dgxxz)
    deallocate(qlm_dgxyz)
    deallocate(qlm_dgxzz)
    deallocate(qlm_dgyyz)
    deallocate(qlm_dgyzz)
    deallocate(qlm_dgzzz)
    deallocate(qlm_ddgxxxx)
    deallocate(qlm_ddgxyxx)
    deallocate(qlm_ddgxzxx)
    deallocate(qlm_ddgyyxx)
    deallocate(qlm_ddgyzxx)
    deallocate(qlm_ddgzzxx)
    deallocate(qlm_ddgxxxy)
    deallocate(qlm_ddgxyxy)
    deallocate(qlm_ddgxzxy)
    deallocate(qlm_ddgyyxy)
    deallocate(qlm_ddgyzxy)
    deallocate(qlm_ddgzzxy)
    deallocate(qlm_ddgxxxz)
    deallocate(qlm_ddgxyxz)
    deallocate(qlm_ddgxzxz)
    deallocate(qlm_ddgyyxz)
    deallocate(qlm_ddgyzxz)
    deallocate(qlm_ddgzzxz)
    deallocate(qlm_ddgxxyy)
    deallocate(qlm_ddgxyyy)
    deallocate(qlm_ddgxzyy)
    deallocate(qlm_ddgyyyy)
    deallocate(qlm_ddgyzyy)
    deallocate(qlm_ddgzzyy)
    deallocate(qlm_ddgxxyz)
    deallocate(qlm_ddgxyyz)
    deallocate(qlm_ddgxzyz)
    deallocate(qlm_ddgyyyz)
    deallocate(qlm_ddgyzyz)
    deallocate(qlm_ddgzzyz)
    deallocate(qlm_ddgxxzz)
    deallocate(qlm_ddgxyzz)
    deallocate(qlm_ddgxzzz)
    deallocate(qlm_ddgyyzz)
    deallocate(qlm_ddgyzzz)
    deallocate(qlm_ddgzzzz)
    deallocate(qlm_kxx)
    deallocate(qlm_kxy)
    deallocate(qlm_kxz)
    deallocate(qlm_kyy)
    deallocate(qlm_kyz)
    deallocate(qlm_kzz)
    deallocate(qlm_dkxxx)
    deallocate(qlm_dkxyx)
    deallocate(qlm_dkxzx)
    deallocate(qlm_dkyyx)
    deallocate(qlm_dkyzx)
    deallocate(qlm_dkzzx)
    deallocate(qlm_dkxxy)
    deallocate(qlm_dkxyy)
    deallocate(qlm_dkxzy)
    deallocate(qlm_dkyyy)
    deallocate(qlm_dkyzy)
    deallocate(qlm_dkzzy)
    deallocate(qlm_dkxxz)
    deallocate(qlm_dkxyz)
    deallocate(qlm_dkxzz)
    deallocate(qlm_dkyyz)
    deallocate(qlm_dkyzz)
    deallocate(qlm_dkzzz)
    deallocate(qlm_alpha)
    deallocate(qlm_betax)
    deallocate(qlm_betay)
    deallocate(qlm_betaz)
    deallocate(qlm_ttt)
    deallocate(qlm_ttx)
    deallocate(qlm_tty)
    deallocate(qlm_ttz)
    deallocate(qlm_txx)
    deallocate(qlm_txy)
    deallocate(qlm_txz)
    deallocate(qlm_tyy)
    deallocate(qlm_tyz)
    deallocate(qlm_tzz)
    
    deallocate(qlm_dqttt)
    deallocate(qlm_dqtpt)
    deallocate(qlm_dqppt)
    deallocate(qlm_dqttp)
    deallocate(qlm_dqtpp)
    deallocate(qlm_dqppp)
    
    deallocate(qlm_tetrad_derivs)

    deallocate(qlm_spin_density)
  end subroutine deallocate_variables

end module qlm_variables

```

qlm_calculate.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_calculate (CCTK_ARGUMENTS)
  use cctk
  use qlm_variables
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  
  integer   :: num_procs, my_proc
  integer   :: pass
  integer   :: h0, hn
  
  character :: msg*1000
  character :: slabel*2, ilabel*8
  character(len=200) :: odir
  integer   :: nchars
 
  logical   :: did_allocate
  
  did_allocate = .false.
  
  num_procs = CCTK_nProcs (cctkGH)
  my_proc   = CCTK_MyProc (cctkGH)
  
  do pass = 1, (num_surfaces + num_procs - 1) / num_procs
     
     ! Calculate the range of horizons for this pass
     h0 = (pass - 1) * num_procs + 1
     
     ! This processor's horizon
     hn = h0 + my_proc
     
     ! If there is nothing to do for this processor, set hn to zero
     if (hn > num_surfaces) hn = 0
    
     ! start calculations already? 
     if (hn > 0) then
        if (cctk_time < begin_qlm_calculations_after(hn)) hn = 0
     end if
     
     if (verbose/=0 .or. veryverbose/=0) then
        if (hn > 0) then
           write (msg, '("Calculating quasi-local quantities for surface ",i4)') hn-1
        else
           write (msg, '("Performing dummy calculation")')
        end if
        call CCTK_INFO (msg)
     end if
     
     if (hn > 0) then
        if (surface_index(hn) == -1 .and. CCTK_EQUALS(surface_name(hn), "")) then
           qlm_calc_error(hn) = 1
           qlm_have_valid_data(hn) = 0
           qlm_have_killing_vector(hn) = 0
           hn = 0
        end if
     end if
     
     if (hn > 0) then
        call qlm_import_surface (CCTK_PASS_FTOF, hn)
        if (qlm_calc_error(hn) /= 0) hn = 0
     endif
     
     if (hn > 0) then
        call qlm_set_coordinates (CCTK_PASS_FTOF, hn)
     end if
     
     if (hn > 0) then
        if (.not. did_allocate) then
           ! allocate 2D arrays
           call allocate_variables (int(maxntheta), int(maxnphi))
           did_allocate = .true.
        end if
     end if
     
     call qlm_interpolate (CCTK_PASS_FTOF, hn)
     
     if (hn > 0) then
        if (qlm_calc_error(hn) /= 0) goto 9999
        
        call qlm_calc_tetrad (CCTK_PASS_FTOF, hn)
        call qlm_calc_newman_penrose (CCTK_PASS_FTOF, hn)
        call qlm_calc_weyl_scalars (CCTK_PASS_FTOF, hn)
        call qlm_calc_twometric (CCTK_PASS_FTOF, hn)
        if (CCTK_EQUALS(killing_vector_method, "axial")) then
           call qlm_killing_axial (CCTK_PASS_FTOF, hn)
        else if (CCTK_EQUALS(killing_vector_method, "eigenvector")) then
           call qlm_killing_transport (CCTK_PASS_FTOF, hn)
           if (qlm_calc_error(hn) /= 0) goto 9999
           call qlm_killing_normalise (CCTK_PASS_FTOF, hn)
        else if (CCTK_EQUALS(killing_vector_method, "gradient")) then
           call qlm_killing_gradient (CCTK_PASS_FTOF, hn)
           call qlm_killing_normalise (CCTK_PASS_FTOF, hn)
        else
           call CCTK_WARN (0, "internal error")
        end if
        if (qlm_calc_error(hn) /= 0) goto 9999
        if (qlm_have_killing_vector(hn) /= 0) then
           call qlm_killing_test (CCTK_PASS_FTOF, hn)
           call qlm_calc_coordinates (CCTK_PASS_FTOF, hn)
        end if
        call qlm_calc_3determinant (CCTK_PASS_FTOF, hn)
        call qlm_analyse (CCTK_PASS_FTOF, hn)
        if (qlm_have_killing_vector(hn) /= 0) then
           call qlm_multipoles (CCTK_PASS_FTOF, hn)
           call qlm_multipoles_normalise (CCTK_PASS_FTOF, hn)
        end if

        if (output_vtk_every /= 0) then
          if (mod(cctk_iteration,output_vtk_every) == 0) then
            write(slabel,'(I2.2)') hn
            write(ilabel,'(I8.8)') cctk_iteration
            call CCTK_ParameterValString (nchars, "out_dir", "IOUtil", odir) 
            call qlm_outputvtk (CCTK_PASS_FTOF, hn, odir(1:nchars)//'/surface'//slabel//'_'//ilabel//'.vtk', 1)
          end if
        end if
        
9999    continue
        
        if (qlm_timederiv_order(hn) < 2) then
           call CCTK_WARN (2, "There were not enough past time levels available for accurate calculations")
        end if
     end if
     
  end do
 
  if (did_allocate) then
     ! release 2D arrays
     call deallocate_variables
  end if
 
  call qlm_broadcast (cctkGH)

  if (veryverbose/=0) then
     call CCTK_INFO ("Done.")
  end if
  
end subroutine qlm_calculate

```

qlm_output_vtk.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"

subroutine qlm_outputvtk(CCTK_ARGUMENTS,nhor,file_name,unit_nr)
  use cctk
  use constants
  use qlm_variables
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  
    integer, intent(in)          :: nhor
    character(len=*), intent(in) :: file_name
    integer, intent(in)          :: unit_nr 

    integer   :: i, j, nth, nph, ngth, ngph
    CCTK_REAL :: xx, yy, zz

    ngth = qlm_nghoststheta(nhor) 
    ngph = qlm_nghostsphi(nhor)
    nth = qlm_ntheta(nhor)-2*ngth
    nph = qlm_nphi(nhor)-2*ngph

    open (unit=unit_nr, file=file_name,action='write')
    
    write(unit_nr,'(A)') '# vtk DataFile Version 2.0' 
    write(unit_nr,'(A)') 'Horizon data' 
    write(unit_nr,'(A)') 'ASCII' 
    write(unit_nr,'(A)') 'DATASET POLYDATA'
    write(unit_nr,'(A,X,I5,X,A)') 'POINTS', nth*nph, 'float'

    do j=1, nth
       do i=1, nph
          xx = qlm_x(j+ngth,i+ngph,nhor) 
          yy = qlm_y(j+ngth,i+ngph,nhor) 
          zz = qlm_z(j+ngth,i+ngph,nhor) 
          write(unit_nr,*) xx, yy, zz 
       end do
    end do

    write(unit_nr,'(A)') ''
    write(unit_nr,'(A,X,I5,X,I10)') 'POLYGONS', nph*(nth-1), 5*nph*(nth-1)
    
    do j=0, nth-2
       do i=0, nph-2
          write(unit_nr,'(I1,4(I6))') 4, j*nph+i, (j+1)*nph+i, (j+1)*nph+i+1, j*nph+i+1
       end do
       write(unit_nr,'(I1,4(I6))') 4, j*nph+nph-1, (j+1)*nph+nph-1, (j+1)*nph, j*nph
    end do

    write(unit_nr,'(A)') ''
    write(unit_nr,'(A,X,I5)') 'POINT_DATA', nth*nph

    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'shape',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'l0',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'l1',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'l2',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'l3',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'n0',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'n1',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'n2',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'n3',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'rem0',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imm0',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'rem1',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imm1',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'rem2',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imm2',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'rem3',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imm3',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renpkappa',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnpkappa',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renptau',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnptau',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renpsigma',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnpsigma',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renprho',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnprho',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renpepsilon',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnpepsilon',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renpgamma',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnpgamma',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renpbeta',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnpbeta',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renpalpha',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnpalpha',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renppi',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnppi',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renpnu',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnpnu',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renpmu',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnpmu',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'renplambda',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'imnplambda',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'repsi0',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'impsi0',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'repsi1',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'impsi1',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'repsi2',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'impsi2',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'repsi3',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'impsi3',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'repsi4',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'impsi4',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'xit',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'xip',unit_nr)
    call qlm_writescalar(CCTK_PASS_FTOF,nth,nph,nhor,'chi',unit_nr)

    close(1)

end subroutine qlm_outputvtk

subroutine qlm_writescalar(CCTK_ARGUMENTS,nth,nph,nhor,array_name,unit_nr)
  use cctk
  use constants
  use qlm_variables
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  
    integer, intent(in)          :: nth, nph, nhor
    character(len=*), intent(in) :: array_name
    integer, intent(in)          :: unit_nr 
    CCTK_REAL                    :: array(1:nth,1:nph)

    integer   :: i, j

    select case (array_name)
        case('shape')
                array(1:nth,1:nph) = qlm_shape(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('l0')
                array(1:nth,1:nph) = qlm_l0(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('l1')
                array(1:nth,1:nph) = qlm_l1(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('l2')
                array(1:nth,1:nph) = qlm_l2(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('l3')
                array(1:nth,1:nph) = qlm_l3(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('n0')
                array(1:nth,1:nph) = qlm_n0(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('n1')
                array(1:nth,1:nph) = qlm_n1(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('n2')
                array(1:nth,1:nph) = qlm_n2(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('n3')
                array(1:nth,1:nph) = qlm_n3(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('rem0')
                array(1:nth,1:nph) = real(qlm_m0(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imm0')
                array(1:nth,1:nph) = aimag(qlm_m0(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('rem1')
                array(1:nth,1:nph) = real(qlm_m1(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imm1')
                array(1:nth,1:nph) = aimag(qlm_m1(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('rem2')
                array(1:nth,1:nph) = real(qlm_m2(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imm2')
                array(1:nth,1:nph) = aimag(qlm_m2(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('rem3')
                array(1:nth,1:nph) = real(qlm_m3(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imm3')
                array(1:nth,1:nph) = aimag(qlm_m3(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renpkappa')
                array(1:nth,1:nph) = real(qlm_npkappa(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnpkappa')
                array(1:nth,1:nph) = aimag(qlm_npkappa(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renptau')
                array(1:nth,1:nph) = real(qlm_nptau(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnptau')
                array(1:nth,1:nph) = aimag(qlm_nptau(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renpsigma')
                array(1:nth,1:nph) = real(qlm_npsigma(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnpsigma')
                array(1:nth,1:nph) = aimag(qlm_npsigma(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renprho')
                array(1:nth,1:nph) = real(qlm_nprho(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnprho')
                array(1:nth,1:nph) = aimag(qlm_nprho(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renpepsilon')
                array(1:nth,1:nph) = real(qlm_npepsilon(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnpepsilon')
                array(1:nth,1:nph) = aimag(qlm_npepsilon(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renpgamma')
                array(1:nth,1:nph) = real(qlm_npgamma(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnpgamma')
                array(1:nth,1:nph) = aimag(qlm_npgamma(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renpbeta')
                array(1:nth,1:nph) = real(qlm_npbeta(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnpbeta')
                array(1:nth,1:nph) = aimag(qlm_npbeta(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renpalpha')
                array(1:nth,1:nph) = real(qlm_npalpha(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnpalpha')
                array(1:nth,1:nph) = aimag(qlm_npalpha(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renppi')
                array(1:nth,1:nph) = real(qlm_nppi(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnppi')
                array(1:nth,1:nph) = aimag(qlm_nppi(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renpnu')
                array(1:nth,1:nph) = real(qlm_npnu(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnpnu')
                array(1:nth,1:nph) = aimag(qlm_npnu(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renpmu')
                array(1:nth,1:nph) = real(qlm_npmu(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnpmu')
                array(1:nth,1:nph) = aimag(qlm_npmu(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('renplambda')
                array(1:nth,1:nph) = real(qlm_nplambda(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('imnplambda')
                array(1:nth,1:nph) = aimag(qlm_nplambda(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('repsi0')
                array(1:nth,1:nph) = real(qlm_psi0(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('impsi0')
                array(1:nth,1:nph) = aimag(qlm_psi0(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('repsi1')
                array(1:nth,1:nph) = real(qlm_psi1(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('impsi1')
                array(1:nth,1:nph) = aimag(qlm_psi1(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('repsi2')
                array(1:nth,1:nph) = real(qlm_psi2(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('impsi2')
                array(1:nth,1:nph) = aimag(qlm_psi2(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('repsi3')
                array(1:nth,1:nph) = real(qlm_psi3(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('impsi3')
                array(1:nth,1:nph) = aimag(qlm_psi3(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('repsi4')
                array(1:nth,1:nph) = real(qlm_psi4(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('impsi4')
                array(1:nth,1:nph) = aimag(qlm_psi4(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor))
        case('xit')
                array(1:nth,1:nph) = qlm_xi_t(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('xip')
                array(1:nth,1:nph) = qlm_xi_p(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
        case('chi')
                array(1:nth,1:nph) = qlm_chi(qlm_nghoststheta(nhor):nth+qlm_nghoststheta(nhor),&
                                                qlm_nghostsphi(nhor):nph+qlm_nghostsphi(nhor),nhor)
    end select

    write(unit_nr,'(/A,X,A,X,A)') 'SCALARS', array_name, 'float 1'
    write(unit_nr,'(A)') 'LOOKUP_TABLE default'
    do j=1, nth
       do i=1, nph
          write(unit_nr,*) array(j,i)
       end do
    end do

end subroutine qlm_writescalar

```

qlm_twometric.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_calc_twometric (CCTK_ARGUMENTS, hn)
  use adm_metric
  use cctk
  use qlm_boundary
  use qlm_derivs
  use qlm_variables
  use ricci
  use ricci2
  use tensor
  use tensor2
  use tensor4
  
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL :: gg(3,3), dgg(3,3,3)
  CCTK_REAL :: ee(3,2), dee(3,2,2)
  CCTK_REAL :: qq(2,2), dqq(2,2,2)
 
  CCTK_REAL :: delta_space(2)
  
  integer   :: i, j
  integer   :: a, b, c, d, e, f
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Calculating two-metric")
  end if
  
  delta_space(:) = (/ qlm_delta_theta(hn), qlm_delta_phi(hn) /)
  
  ! Calculate the two-metric
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        
        gg(1,1) = qlm_gxx(i,j)
        gg(1,2) = qlm_gxy(i,j)
        gg(1,3) = qlm_gxz(i,j)
        gg(2,2) = qlm_gyy(i,j)
        gg(2,3) = qlm_gyz(i,j)
        gg(3,3) = qlm_gzz(i,j)
        gg(2,1) = gg(1,2)
        gg(3,1) = gg(1,3)
        gg(3,2) = gg(2,3)
        
        dgg(1,1,1) = qlm_dgxxx(i,j)
        dgg(1,2,1) = qlm_dgxyx(i,j)
        dgg(1,3,1) = qlm_dgxzx(i,j)
        dgg(2,2,1) = qlm_dgyyx(i,j)
        dgg(2,3,1) = qlm_dgyzx(i,j)
        dgg(3,3,1) = qlm_dgzzx(i,j)
        dgg(1,1,2) = qlm_dgxxy(i,j)
        dgg(1,2,2) = qlm_dgxyy(i,j)
        dgg(1,3,2) = qlm_dgxzy(i,j)
        dgg(2,2,2) = qlm_dgyyy(i,j)
        dgg(2,3,2) = qlm_dgyzy(i,j)
        dgg(3,3,2) = qlm_dgzzy(i,j)
        dgg(1,1,3) = qlm_dgxxz(i,j)
        dgg(1,2,3) = qlm_dgxyz(i,j)
        dgg(1,3,3) = qlm_dgxzz(i,j)
        dgg(2,2,3) = qlm_dgyyz(i,j)
        dgg(2,3,3) = qlm_dgyzz(i,j)
        dgg(3,3,3) = qlm_dgzzz(i,j)
        dgg(2,1,:) = dgg(1,2,:)
        dgg(3,1,:) = dgg(1,3,:)
        dgg(3,2,:) = dgg(2,3,:)
        
        ee(1,1:2) = deriv (qlm_x(:,:,hn), i, j, delta_space)
        ee(2,1:2) = deriv (qlm_y(:,:,hn), i, j, delta_space)
        ee(3,1:2) = deriv (qlm_z(:,:,hn), i, j, delta_space)
        
        dee(1,1:2,1:2) = deriv2 (qlm_x(:,:,hn), i, j, delta_space)
        dee(2,1:2,1:2) = deriv2 (qlm_y(:,:,hn), i, j, delta_space)
        dee(3,1:2,1:2) = deriv2 (qlm_z(:,:,hn), i, j, delta_space)
        
        do a=1,2
           do b=1,2
              qq(a,b) = 0
              do c=1,3
                 do d=1,3
                    qq(a,b) = qq(a,b) + gg(c,d) * ee(c,a) * ee(d,b)
                 end do
              end do
           end do
        end do
        
        do a=1,2
           do b=1,2
              do c=1,2
                 dqq(a,b,c) = 0
                 do d=1,3
                    do e=1,3
                       do f=1,3
                          dqq(a,b,c) = dqq(a,b,c) + dgg(d,e,f) * ee(d,a) * ee(e,b) * ee(f,c)
                       end do
                       dqq(a,b,c) = dqq(a,b,c) + gg(d,e) * dee(d,a,c) * ee(e,b)
                       dqq(a,b,c) = dqq(a,b,c) + gg(d,e) * ee(d,a) * dee(e,b,c)
                    end do
                 end do
              end do
           end do
        end do
        
        ! Could also calculate this as:
        !    q^ab = m^a mbar^b + mbar^a m^b
        qlm_qtt(i,j,hn) = qq(1,1)
        qlm_qtp(i,j,hn) = qq(1,2)
        qlm_qpp(i,j,hn) = qq(2,2)
        
        qlm_dqttt(i,j) = dqq(1,1,1)
        qlm_dqtpt(i,j) = dqq(1,2,1)
        qlm_dqppt(i,j) = dqq(2,2,1)
        qlm_dqttp(i,j) = dqq(1,1,2)
        qlm_dqtpp(i,j) = dqq(1,2,2)
        qlm_dqppp(i,j) = dqq(2,2,2)
        
     end do
  end do
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_qtt(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_qtp(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_qpp(:,:,hn), +1)
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_dqttt(:,:), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_dqtpt(:,:), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_dqppt(:,:), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_dqttp(:,:), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_dqtpp(:,:), -1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_dqppp(:,:), -1)
  
end subroutine qlm_calc_twometric

```

qlm_boundary.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



module qlm_boundary
  use cctk
  implicit none
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  private
  public set_boundary
  
  interface set_boundary
     module procedure set_boundary_real
     module procedure set_boundary_complex
  end interface
  
contains
  
  subroutine set_boundary_real (CCTK_ARGUMENTS, hn, f, parity)
    DECLARE_CCTK_ARGUMENTS
    integer, intent(in) :: hn
    CCTK_REAL           :: f(:,:)
    integer, intent(in) :: parity
    
    CCTK_REAL, allocatable :: ff(:,:)
    
    integer :: ni, nj, gi, gj
    
    integer :: i, j, jj
    
    if (abs(parity) /= 1) then
       call CCTK_WARN (0, "Parity must be +1 or -1")
    end if
    
    
    
    ni = qlm_ntheta(hn)
    nj = qlm_nphi(hn)
    gi = qlm_nghoststheta(hn)
    gj = qlm_nghostsphi(hn)
    
    
    
    f(       :gi, :nj) = -42
    f(ni-gi+1:ni, :nj) = -42
    f(:ni,        :gj) = -42
    f(:ni, nj-gi+1:nj) = -42
    
    allocate (ff(gi, nj))
    
    ! lower theta
    ff(:, :nj) = f(1+gi:2*gi, :nj)
    
    ! polar boundary condition at north pole
    do j=1,nj/2
       do i=1,gi
          jj = j + (nj-2*gj) / 2
          f(i,j) = parity * ff(gi-i+1,jj)
       end do
    end do
    do j=nj/2+1,nj
       do i=1,gi
          jj = j - (nj-2*gj) / 2
          f(i,j) = parity * ff(gi-i+1,jj)
       end do
    end do
    
    ! upper theta
    ff(:, :nj) = f(ni-2*gi+1:ni-gi, :nj)
    
    ! polar boundary condition at south pole
    do j=1,nj/2
       do i=1,gi
          jj = j + (nj-2*gj) / 2
          f(ni-i+1,j) = parity * ff(i,jj)
       end do
    end do
    do j=nj/2+1,nj
       do i=1,gi
          jj = j - (nj-2*gj) / 2
          f(ni-i+1,j) = parity * ff(i,jj)
       end do
    end do
    
    deallocate (ff)
    
    
    
    allocate (ff(ni,gj))
    
    ! lower phi
    ff(:ni, :) = f(:ni, nj-2*gj+1:nj-gj)
    
    ! periodic boundary at null meridian
    do j=1,gj
       do i=1,ni
          f(i,j) = ff(i,j)
       end do
    end do
    
    ! upper phi
    ff(:ni, :) = f(:ni, gj+1:2*gj)
    
    ! periodic boundary at null meridian
    do j=1,gj
       do i=1,ni
          f(i,nj-j+1) = ff(i,gj-j+1)
       end do
    end do
    
    deallocate (ff)
    
    
    
    f(ni+1:, :nj) = 0
    f(:, nj+1:) = 0
    
  end subroutine set_boundary_real
  
  
  
  subroutine set_boundary_complex (CCTK_ARGUMENTS, hn, f, parity)
    DECLARE_CCTK_ARGUMENTS
    integer, intent(in) :: hn
    CCTK_COMPLEX        :: f(:,:)
    integer, intent(in) :: parity
    
    CCTK_REAL :: fre(size(f,1),size(f,2))
    CCTK_REAL :: fim(size(f,1),size(f,2))
    
    integer :: ni, nj, gi, gj
    
    ni = qlm_ntheta(hn)
    nj = qlm_nphi(hn)
    gi = qlm_nghoststheta(hn)
    gj = qlm_nghostsphi(hn)
    
    f(       :gi, :nj) = 0
    f(ni-gi+1:ni, :nj) = 0
    f(:ni,        :gj) = 0
    f(:ni, nj-gj+1:nj) = 0
    
    fre = real(f)
    fim = aimag(f)
    call set_boundary_real (CCTK_PASS_FTOF, hn, fre, parity)
    call set_boundary_real (CCTK_PASS_FTOF, hn, fim, parity)
    f = cmplx(fre, fim, kind(f))
  end subroutine set_boundary_complex
  
end module qlm_boundary

```

qlm_set_coordinates.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_set_coordinates (CCTK_ARGUMENTS, hn)
  use cctk
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL :: theta, phi
  CCTK_REAL :: sin_theta, cos_theta, sin_phi, cos_phi
  
  integer :: i, j
  
  ! Calculate the coordinates
  do j = 1, qlm_nphi(hn)
     do i = 1, qlm_ntheta(hn)
        theta = qlm_origin_theta(hn) + (i-1)*qlm_delta_theta(hn)
        phi   = qlm_origin_phi(hn)   + (j-1)*qlm_delta_phi(hn)
        
        sin_theta = sin(theta)
        cos_theta = cos(theta)
        sin_phi   = sin(phi)
        cos_phi   = cos(phi)
        
        qlm_x(i,j,hn) = qlm_origin_x(hn) + qlm_shape(i,j,hn) * sin_theta * cos_phi
        qlm_y(i,j,hn) = qlm_origin_y(hn) + qlm_shape(i,j,hn) * sin_theta * sin_phi
        qlm_z(i,j,hn) = qlm_origin_z(hn) + qlm_shape(i,j,hn) * cos_theta
        
        qlm_x_p(i,j,hn) = qlm_origin_x_p(hn) + qlm_shape_p(i,j,hn) * sin_theta * cos_phi
        qlm_y_p(i,j,hn) = qlm_origin_y_p(hn) + qlm_shape_p(i,j,hn) * sin_theta * sin_phi
        qlm_z_p(i,j,hn) = qlm_origin_z_p(hn) + qlm_shape_p(i,j,hn) * cos_theta
        
        qlm_x_p_p(i,j,hn) = qlm_origin_x_p_p(hn) + qlm_shape_p_p(i,j,hn) * sin_theta * cos_phi
        qlm_y_p_p(i,j,hn) = qlm_origin_y_p_p(hn) + qlm_shape_p_p(i,j,hn) * sin_theta * sin_phi
        qlm_z_p_p(i,j,hn) = qlm_origin_z_p_p(hn) + qlm_shape_p_p(i,j,hn) * cos_theta
     end do
  end do
  
end subroutine qlm_set_coordinates

```

qlm_killing_axial.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_killing_axial (CCTK_ARGUMENTS, hn)
  use cctk
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL :: xi(2), chi
  integer   :: i, j
  
  do j = 1, qlm_nphi(hn)
     do i = 1, qlm_ntheta(hn)
        
        xi(1) = 0
        xi(2) = 1
        
        chi = 0
        
        qlm_xi_t(i,j,hn) = xi(1)
        qlm_xi_p(i,j,hn) = xi(2)
        
        qlm_chi(i,j,hn) = chi
        
     end do
  end do
  
end subroutine qlm_killing_axial

```

qlm_killing_normalise.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_killing_normalise (CCTK_ARGUMENTS, hn)
  use cctk
  use qlm_killing_normalisation
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL, parameter :: one = 1
  
  integer, parameter :: ngeodesics = 7
  
  CCTK_REAL :: theta
  CCTK_REAL :: factor, factors(ngeodesics)
  logical   :: found(ngeodesics)
  
  integer   :: nsteps
  integer   :: ii
  integer   :: i, j
  
  character :: msg*1000
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Normalising Killing vector field")
  end if
  
  
  
  ! Starting meridian
  j = 1+qlm_nghostsphi(hn)
  
  
  
  if (veryverbose/=0) call CCTK_INFO ("Calculating normalisation factor:")
  
  do ii=1,ngeodesics
     i = 1 + qlm_nghoststheta(hn) &
          + ii * (qlm_ntheta(hn) - 2*qlm_nghoststheta(hn) - 1) / (ngeodesics+1)
     if (qlm_xi_p(i,j,hn) < 0) then
        qlm_xi_t(:,:,hn) = -qlm_xi_t(:,:,hn)
        qlm_xi_p(:,:,hn) = -qlm_xi_p(:,:,hn)
        qlm_chi (:,:,hn) = -qlm_chi (:,:,hn)
     end if
     theta = qlm_origin_theta(hn) + (i-1) * qlm_delta_theta(hn)
     call killing_factor (CCTK_PASS_FTOF, hn, theta, factors(ii), nsteps)
     found(ii) = nsteps>0
  end do
  if (any(found)) then
     if (CCTK_EQUALS(killing_vector_normalisation, "average")) then
        if (count(found) >= 3) then
           ! ignore smallest and largest factors
           ii = minloc(factors, 1, found)
           if (ii<=0) call CCTK_WARN (0, "internal error")
           found(ii) = .false.
           ii = maxloc(factors, 1, found)
           if (ii<=0) call CCTK_WARN (0, "internal error")
           found(ii) = .false.
        end if
     else if (CCTK_EQUALS(killing_vector_normalisation, "median")) then
        do while (count(found) >= 3)
           ! ignore smallest and largest factors
           ii = minloc(factors, 1, found)
           if (ii<=0) call CCTK_WARN (0, "internal error")
           found(ii) = .false.
           ii = maxloc(factors, 1, found)
           if (ii<=0) call CCTK_WARN (0, "internal error")
           found(ii) = .false.
        end do
     else
        call CCTK_WARN (0, "internal error")
     end if
     ! average factors
     factor = product(factors, found) ** (one / count(found))
  else
     call CCTK_WARN (1, "Did not manage to integrate along a Killing vector field line loop")
     ! qlm_calc_error(hn) = 1
     qlm_have_killing_vector(hn) = 0
     factor = 1
     goto 9999
  end if
  
  
  
  if (veryverbose/=0) then
     write (msg, '("Normalising xi with the factor ",g16.6)') factor
     call CCTK_INFO (msg)
  end if
  qlm_xi_t(:,:,hn) = qlm_xi_t(:,:,hn) * factor
  qlm_xi_p(:,:,hn) = qlm_xi_p(:,:,hn) * factor
  qlm_chi (:,:,hn) = qlm_chi (:,:,hn) * factor
  
  
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Checking normalisation factors for various Killing vector field line loops:")
     do ii=1,ngeodesics
        i = 1 + qlm_nghoststheta(hn) &
             + ii * (qlm_ntheta(hn) - 2*qlm_nghoststheta(hn) - 1) / (ngeodesics+1)
        theta = qlm_origin_theta(hn) + (i-1) * qlm_delta_theta(hn)
        call killing_factor (CCTK_PASS_FTOF, hn, theta, factor, nsteps)
     end do
  end if
  
  ! qlm_have_killing_vector(hn) = 1
  
9999 continue
  
end subroutine qlm_killing_normalise

```

qlm_3determinant.F90:
```
#include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



SUBROUTINE qlm_calc_3determinant (CCTK_ARGUMENTS, hn)
  USE adm_metric
  USE cctk
  USE qlm_boundary
  USE qlm_derivs
  USE qlm_variables
  USE tensor
  
  IMPLICIT NONE
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  INTEGER :: hn
  
  CCTK_REAL    :: gg(3,3)
  CCTK_REAL    :: alfa   
  CCTK_REAL    :: beta(3)
  CCTK_REAL    :: g4(0:3,0:3)
  CCTK_COMPLEX :: mm(0:3)
  CCTK_REAL    :: rr(3), rr_p(3), rr_p_p(3)
  CCTK_REAL    :: Ttilde(0:3)
  CCTK_REAL    :: a
  CCTK_COMPLEX :: d

  CCTK_REAL    :: t0, t1, t2
  logical      :: ce0, ce1, ce2
  CCTK_REAL    :: delta_space(2)

  INTEGER      :: i, j
  CCTK_REAL    :: theta, phi
  
  IF (veryverbose/=0) THEN
     CALL CCTK_INFO ("Computing 3-Volume Element of Surface")
  END IF
  
  t0 = qlm_time(hn)
  t1 = qlm_time_p(hn)
  t2 = qlm_time_p_p(hn)
  
  ce0 = qlm_have_valid_data(hn) == 0
  ce1 = qlm_have_valid_data_p(hn) == 0
  ce2 = qlm_have_valid_data_p_p(hn) == 0
  
  delta_space(:) = (/ qlm_delta_theta(hn), qlm_delta_phi(hn) /)
  
  ! Calculate the coordinates
  DO j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     DO i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        theta = qlm_origin_theta(hn) + (i-1)*qlm_delta_theta(hn)
        phi   = qlm_origin_phi(hn)   + (j-1)*qlm_delta_phi(hn)
        
        ! Get the stuff from the arrays
        gg(1,1) = qlm_gxx(i,j)
        gg(1,2) = qlm_gxy(i,j)
        gg(1,3) = qlm_gxz(i,j)
        gg(2,2) = qlm_gyy(i,j)
        gg(2,3) = qlm_gyz(i,j)
        gg(3,3) = qlm_gzz(i,j)
        gg(2,1) = gg(1,2)
        gg(3,1) = gg(1,3)
        gg(3,2) = gg(2,3)
        
        alfa = qlm_alpha(i,j)
        
        beta(1) = qlm_betax(i,j)
        beta(2) = qlm_betay(i,j)
        beta(3) = qlm_betaz(i,j)
        
        mm(0) = qlm_m0(i,j,hn)
        mm(1) = qlm_m1(i,j,hn)
        mm(2) = qlm_m2(i,j,hn)
        mm(3) = qlm_m3(i,j,hn)
        
        ! Build the four-metric
        CALL calc_4metric (gg,alfa,beta, g4)
        
        ! Find a 3rd vector of triad
        rr(1) = qlm_x(i,j,hn)
        rr(2) = qlm_y(i,j,hn)
        rr(3) = qlm_z(i,j,hn)
        
        rr_p(1) = qlm_x_p(i,j,hn)
        rr_p(2) = qlm_y_p(i,j,hn)
        rr_p(3) = qlm_z_p(i,j,hn)
        
        rr_p_p(1) = qlm_x_p_p(i,j,hn)
        rr_p_p(2) = qlm_y_p_p(i,j,hn)
        rr_p_p(3) = qlm_z_p_p(i,j,hn)
        
        Ttilde(0)   = 1
        Ttilde(1:3) = timederiv (rr, rr_p, rr_p_p, t0,t1,t2, ce0,ce1,ce2)
        
        ! Compute some scalar products
        a=SUM(MATMUL(g4, Ttilde)*Ttilde)
        d=SUM(MATMUL(g4, mm)*Ttilde)
        
        ! This is the determinant
        qlm_3det(i,j,hn)=a-2*CONJG(d)*d
        
     END DO
  END DO

  CALL set_boundary (CCTK_PASS_FTOF, hn, qlm_3det(:,:,hn), +1)

END SUBROUTINE qlm_calc_3determinant

```

qlm_gram_schmidt.F90:
```
#include "cctk.h"

module qlm_gram_schmidt
  implicit none
  private
  public gram_schmidt_project
  public gram_schmidt_normalise
  
contains
  
  subroutine gram_schmidt_project (g, dg, y, dy, y2, x, dx)
    CCTK_REAL, intent(in)    :: g(0:3,0:3), dg(0:3,0:3,0:3)
    CCTK_REAL, intent(in)    :: y(0:3), dy(0:3,0:3), y2
    CCTK_REAL, intent(inout) :: x(0:3), dx(0:3,0:3)
    CCTK_REAL                :: z(0:3), dz(0:3,0:3)
    
    integer :: a, b, d, e
    
    do a=0,3
       z(a) = x(a)
       do d=0,3
          do e=0,3
             z(a) = z(a) - g(d,e) * x(d) * y(e) * y(a) / y2
          end do
       end do
    end do
    
    do a=0,3
       do b=0,3
          dz(a,b) = dx(a,b)
          do d=0,3
             do e=0,3
                dz(a,b) = dz(a,b) &
                     - dg(d,e,b) * x(d) * y(e) * y(a) / y2 &
                     - g(d,e) * dx(d,b) * y(e) * y(a) / y2 &
                     - g(d,e) * x(d) * dy(e,b) * y(a) / y2 &
                     - g(d,e) * x(d) * y(e) * dy(a,b) / y2
             end do
          end do
       end do
    end do
    
    x = z
    dx = dz
  end subroutine gram_schmidt_project
  
  subroutine gram_schmidt_normalise (g, dg, x, dx, x2)
    CCTK_REAL, intent(in)    :: g(0:3,0:3), dg(0:3,0:3,0:3)
    CCTK_REAL, intent(inout) :: x(0:3), dx(0:3,0:3)
    CCTK_REAL, intent(in)    :: x2
    CCTK_REAL, parameter     :: two=2, half=1/two
    CCTK_REAL                :: z2, dz2(0:3)
    CCTK_REAL                :: z(0:3), dz(0:3,0:3)
    
    integer :: a, b, d, e
    
    z2 = 0
    do d=0,3
       do e=0,3
          z2 = z2 + g(d,e) * x(d) * x(e)
       end do
    end do
    
    do a=0,3
       dz2(a) = 0
       do d=0,3
          do e=0,3
             dz2(a) = dz2(a) &
                  + dg(d,e,a) * x(d) * x(e) &
                  + g(d,e) * dx(d,a) * x(e) &
                  + g(d,e) * x(d) * dx(e,a)
          end do
       end do
    end do
    
    do a=0,3
       z(a) = x(a) / sqrt(z2 / x2)
    end do
    
    do a=0,3
       do b=0,3
          dz(a,b) = (+ dx(a,b) * z2 / x2 &
               &     - half * x(a) * dz2(b) / x2) / sqrt(z2 / x2)**3
       end do
    end do
    
    x = z
    dx = dz
  end subroutine gram_schmidt_normalise
  
end module qlm_gram_schmidt

```

qlm_broadcast.c:
```
#include <assert.h>
#include <stdio.h>
#include <stdlib.h>

#include <cctk.h>
#include <cctk_Arguments.h>
#include <cctk_Parameters.h>

#ifdef CCTK_MPI
#  include <mpi.h>
#endif



/* Broadcast a vector element of a grid group */
static void
bcast (cGH const * restrict const cctkGH,
       char const * restrict const group,
       int const vecind,
       int const root)
{
#ifdef CCTK_MPI
  
  int ierr;
  
  assert (group);
  
  MPI_Comm comm;
  if (CCTK_IsFunctionAliased ("GetMPICommWorld"))
  {
    comm = * (MPI_Comm const *) GetMPICommWorld (cctkGH);
  }
  else
  {
    comm = MPI_COMM_WORLD;
  }
  
  int num_procs;
  MPI_Comm_size (comm, & num_procs);
  
  assert (root >= 0 && root < num_procs);
  
  int const gi = CCTK_GroupIndex (group);
  assert (gi >= 0);
  
  cGroup data;
  ierr = CCTK_GroupData (gi, & data);
  assert (! ierr);
  
  assert (vecind >= 0 && vecind < data.vectorlength);
  
  if (data.numvars == 0) return;
  
  MPI_Datatype mpitype;
  int items;
  switch (data.vartype)
  {
  case CCTK_VARIABLE_INT:
    if (sizeof (CCTK_INT) == sizeof (int)) {
      mpitype = MPI_INT;
    } else if (sizeof (CCTK_INT) == sizeof (long)) {
      mpitype = MPI_LONG;
    } else if (sizeof (CCTK_INT) == sizeof (long long)) {
      mpitype = MPI_LONG_LONG;
    } else {
      CCTK_ERROR("Unsupported CCTK_INT type");
    }
    items = 1;
    break;
  case CCTK_VARIABLE_REAL:
    assert (sizeof (CCTK_REAL) == sizeof (double));
    mpitype = MPI_DOUBLE;
    items = 1;
    break;
  case CCTK_VARIABLE_COMPLEX:
    assert (sizeof (CCTK_COMPLEX) == 2 * sizeof (double));
    mpitype = MPI_DOUBLE;
    items = 2;
    break;
  default:
    assert (0);
  }
  assert (items > 0);
  
  cGroupDynamicData dyndata;
  ierr = CCTK_GroupDynamicData (cctkGH, gi, & dyndata);
  assert (! ierr);
  
  int elems = 1;
  {
    int d;
    for (d = 0; d < dyndata.dim; ++ d)
    {
      elems *= dyndata.lsh[d];
    }
  }
  assert (elems >= 0);
  
  int const v0 = CCTK_FirstVarIndexI (gi);
  assert (v0 >= 0);
  
  int size;
  MPI_Type_size (mpitype, & size);
  assert (items * size == CCTK_VarTypeSize (data.vartype));
  
  int const numvectors = data.numvars / data.vectorlength;
  
  {
    int vec;
    for (vec = 0; vec < numvectors; ++ vec)
    {
      int const vi = v0 + vecind + data.vectorlength * vec;
      void * restrict const ptr = CCTK_VarDataPtrI (cctkGH, 0, vi);
      assert (ptr);
      
      MPI_Bcast (ptr, elems * items, mpitype, root, comm);
    }
  }

#endif  /* ifdef CCTK_MPI */
}


void CCTK_FCALL
CCTK_FNAME(qlm_broadcast) (CCTK_POINTER_TO_CONST * restrict cctkGH_);

void CCTK_FCALL
CCTK_FNAME(qlm_broadcast) (CCTK_POINTER_TO_CONST * restrict const cctkGH_)
{
  cGH const * restrict const cctkGH = * (cGH const * const *) cctkGH_;
  DECLARE_CCTK_ARGUMENTS;
  DECLARE_CCTK_PARAMETERS;
  
  if (veryverbose)
  {
    CCTK_INFO ("Broadcasting quasi-local measures");
  }
  
  int const num_procs = CCTK_nProcs (cctkGH);
  int hn; 
  for (hn = 0; hn < num_surfaces; ++ hn)
  {
    int const root = hn % num_procs;
    
    bcast (cctkGH, "QuasiLocalMeasures::qlm_state"      , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_state_p"    , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_grid_int"   , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_grid_real"  , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_grid_real_p", hn, root);
    
    bcast (cctkGH, "QuasiLocalMeasures::qlm_shapes"               , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_shapes_p"             , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_coordinates"          , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_tetrad_l"             , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_tetrad_n"             , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_tetrad_m"             , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_newman_penrose"       , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_weyl_scalars"         , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_ricci_scalars"        , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_twometric"            , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_killing_vector"       , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_killed_twometric"     , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_invariant_coordinates", hn, root);
    
    bcast (cctkGH, "QuasiLocalMeasures::qlm_multipole_moments", hn, root);
    
    bcast (cctkGH, "QuasiLocalMeasures::qlm_3determinant", hn, root);
    
    bcast (cctkGH, "QuasiLocalMeasures::qlm_scalars"  , hn, root);
    bcast (cctkGH, "QuasiLocalMeasures::qlm_scalars_p", hn, root);
    
  } /* for hn */
}

```


combined_doc_context: ## README (README):
```
Cactus Code Thorn QuasiLocalMeasures
Thorn Author(s)     : Olaf Dreyer
                      Badri Krishnan
                      Erik Schnetter <schnetter@cct.lsu.edu>
                      Deirdre Shoemaker
                      Michael Jasiulek
Thorn Maintainer(s) : Erik Schnetter <schnetter@cct.lsu.edu>
--------------------------------------------------------------------------

Purpose of the thorn:

Calculate quasi-local measures such as masses, momenta, or angular
momenta and related quantities on closed two-dimentional surfaces,
including on horizons.


Some Literature:

Isolated Horizons:

Olaf Dreyer, Badri Krishnan, Erik Schnetter, Deirdre Shoemaker
Introduction to Isolated Horizons in Numerical Relativity
Phys. Rev. D 67 (2003) 024018
arXiv:gr-qc/0206008

Multipole moments:

Abhay Ashtekar, Badri Krishnan
Dynamical Horizons and their Properties
Phys. Rev. D 68 (2003) 104030
arXiv:gr-qc/0308033

Dynamical horizons:

Erik Schnetter, Badri Krishnan, Florian Beyer
ntroduction to dynamical horizons in numerical relativity
Phys. Rev. D 74 (2006) 024028
arXiv:gr-qc/0604015

Quasi-local measures:

Lszl B. Szabados
Quasi-Local Energy-Momentum and Angular Momentum in GR: A Review Article
Living Rev. Relativity 7 (2004) 4
http://www.livingreviews.org/lrr-2004-4

Andrew P. Lundgren, Bjoern S. Schmekel, James W. York, Jr.
Self-Renormalization of the Classical Quasilocal Energy
arXiv:gr-qc/0610088

Tetrad formalism:

GRwiki
http://grwiki.physics.ncsu.edu/

```

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

```tex
=== documentation.tex ===
% *======================================================================*
%  Cactus Thorn template for ThornGuide documentation
%  Author: Ian Kelley
%  Date: Sun Jun 02, 2002
%
%  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
%  relevant 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
%       % START CACTUS THORNGUIDE",
%     except for filling in the title, author, date, etc. fields.
%        - Each of these fields should only be on ONE line.
%        - Author names should be separated with a \\ or a comma.
%   - You can define your own macros, but they must appear after
%     the START CACTUS THORNGUIDE line, and must 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 graphicx package.
%     More specifically, with the "\includegraphics" command.  Do
%     not specify any graphic file extensions in your .tex file. This
%     will allow us to create a PDF version of the ThornGuide
%     via pdflatex.
%   - References should be included with the latex "\bibitem" command.
%   - Use \begin{abstract}...\end{abstract} instead of \abstract{...}
%   - Do not use \appendix, instead include any appendices you need as
%     standard sections.
%   - 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/}}
%
% *======================================================================*

\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{Erik Schnetter \textless schnetter@cct.lsu.edu\textgreater}

% The title of the document (not necessarily the name of the Thorn)
\title{QuasoLocalMeasures}

% the date your document was last changed
\date{2010-04-02}

\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}
  Calculate quasi-local measures such as masses, momenta, or angular
  momenta and related quantities on closed two-dimentional surfaces,
  including on horizons.
\end{abstract}

% The following sections are suggestive only.
% Remove them or add your own.

\section{A note on evaluating 3D integrals on the horizon world tube}

[NOTE: Ignore the stuff below.  You can do that much easier.]

\subsection{Integral transformation}

The papers about dynamical horizons contain integrals over the 3D
horizon world tube, expressed e.g.\ as
\begin{eqnarray}
   \int X\; d^3V
\end{eqnarray}
where $X$ is some quantity that lives on the horizon.  These integrals
have to be transformed into a $2+1$ form so that they can be
conveniently evaluated, e.g.\ as
\begin{eqnarray}
   \int X\; A\, d^2S\, dt
\end{eqnarray}
where $d^2S$ is the area element on the horizon cross section
contained in $\Sigma$, and $dt$ is the coordinate time differential.
The factor $A$ should contain the extra terms due to this coordinate
transformation.

Starting from the $3$-volume element $d^3V$, let us first decompose
it into the $2$-volume element $d^2S$ and a ``time'' coordinate on the
horizon, which we call $\sigma$.  Note that $\sigma$ will generally be
a spacelike coordinate for dynamical horizons.  Let $\mathbf{Q}$ be
the induced $3$-metric on the horizon, and $\mathbf{q}$ be the induced
$2$-metric on the cross section.
Then it is
\begin{eqnarray}
   d^3V & = & \sqrt{\det Q}\; d\theta\, d\phi\, d\sigma
\\
   & = & \frac{\sqrt{\det Q}}{\sqrt{\det q}}\; d^2S\, d\sigma
\end{eqnarray}
because $d^2S = \sqrt{\det q}\, d\theta\, d\phi$.

The coordinate time differential $dt$ and the differential $d\sigma$
will in general not be aligned because the horizon world tube will in
general not have a static coordinate shape.  It is
\begin{eqnarray}
   d\tau   & = & (\cosh \alpha)\, dt + (\sinh \alpha)\, ds
\\
   d\sigma & = & (\cosh \alpha)\, ds + (\sinh \alpha)\, dt
\end{eqnarray}
where $s$ is a radial coordinate perpendicular to the horizon and also
perpendicular to $t$, and $\tau$ is perpendicular to $\sigma$ and lies
in the plan spanned by $t$ and $s$.  $\tau$ and $\sigma$ are depend on
$t$ and $s$ via a Lorentz boost.  Thus we have
\begin{eqnarray}
   \frac{d\sigma}{dt} & = & (\cosh \alpha)\, \frac{ds}{dt} + (\sinh
   \alpha)\, \frac{dt}{dt}
\\
   & = & \sinh \alpha \quad\textrm{.}
\end{eqnarray}

Putting everything together we arrive at
\begin{eqnarray}
   \int X\; \frac{\sqrt{\det Q}}{\sqrt{\det q}}\; (\sinh \alpha)\,
   d^2S\, dt \quad\textrm{.}
\end{eqnarray}



\subsection{The ``lapse'' function $N_R$}

Starting from
\begin{eqnarray}
   N_R & = & | \partial R |
\end{eqnarray}
we find, since the radius $R$ changes only in the $\sigma$ direction,
\begin{eqnarray}
   N_R^2 & = & g^{\sigma\sigma}\, (\partial_\sigma R)\,
   (\partial_\sigma R) \quad\textrm{.}
\end{eqnarray}

If we assume $\partial_\tau R = 0$ and write $\partial_t R = \dot R$,
and use the relations between $\sigma$ and $t$ from above, we get
\begin{eqnarray}
   \dot R & = & \partial_t R
\\
   & = & \frac{\partial \tau}{\partial t} \partial_\tau R +
   \frac{\partial \sigma}{\partial t} \partial_\sigma R
\\
   & = & \sinh \alpha\, \partial_\sigma R
\end{eqnarray}
[NOTE: but $\partial_t \alpha \ne 0$.]
and therefore
\begin{eqnarray}
   \partial_\sigma R & = & \frac{1}{\sinh \alpha}\; \dot R
   \quad\textrm{.}
\end{eqnarray}

Additionally we have $g^{\sigma\sigma} = g^{ab} \sigma_a \sigma_b =
g_{ab} \sigma^a \sigma^b$ where $\sigma^a$ is the unit vector in the
$\sigma$ direction, i.e.\
\begin{eqnarray}
   \tau^a   & = & (\cosh \alpha)\, t^a + (\sinh \alpha)\, s^a
\\
   \sigma^a & = & (\cosh \alpha)\, s^a + (\sinh \alpha)\, t^a
\end{eqnarray}



\subsection{Special Behaviour}

In order to use the IsolatedHorizon thorn on existing data
(postprocessing), the following procedure is necessary.

\begin{itemize}

\item

Computing time-independent quantities.\\

The 3-metric and the extrinsic curvature must be available in HDF5
files.

\begin{itemize}

\item Set up a parameter file for a grid structure that contains the
  region around the horizon.  The refinement level structure and grid
  spacing etc. needs to be the same as in the HDF5 files, but the
  grids can be much smaller.  You can also leave out some finer grids,
  i.e., reduce the number of levels.  However, the coarse grid spacing
  must remain the same.  The symmetries must also be the same.

\item Use the file reader and thorn AEIThorns/IDFileADM to read in the
  ADM variables from the files.  The parameter file does not need to
  activate BSSN\_MoL or any time evolution mechanism.  IDFileADM acts
  as provider for initial data, so you don't need any other initial
  data either.

\item Set up your parameter file so that the AH finder runs, stores
  the horizon shape in SphericalSurface,
  and IsolatedHorizon accesses these data.\\

\end{itemize}

This gives you the time-independent variables on the horizon, i.e.,
mostly the spin.  It also allows you to look for apparent horizons if
you don't know where they are.


\item
  Computing time-independent quantities, e.g.\ 3-determinant of the horizon\\

\begin{itemize}

\item Performing some time steps is necessary. Either read in lapse
  and shift from files, or set them arbitrarily (e.g.\ lapse one,
  shift zero).

\item Activate a time evolution thorn, i.e., BSSN\_MoL, MoL, Time,
  etc.  In order to fill the past time levels, just choose
  MoL::initial\_data\_is\_crap.  If you have hydrodynamics, read in
  the hydro variables as well.

\item Only two time steps are required. Remember that the output of
  IsolatedHorizon for iteration 0 and 1 are incorrect or very
  inaccurate, since the past time levels are not correct, and hence
  the time derivatives that IsolatedHorizon calculates are wrong.
  However, iteration 2 should be good.  (One could also perform 5
  iterations and cross-check.)

\end{itemize}


\item

  If data for the extrinsic curvature is not available, but those for
  the 3-metric, lapse, and shift for consecutive time steps are (that
  is, if you have data suitable for finding event horizons), then one
  needs to reconstruct the extrinsic curvature first.  There is a
  thorn AEIThorns/CalcK that helps with that.  It reads the data for
  the 4-metric timestep after timestep, calculates the time derivative
  of the 3-metric through finite differencing in time, and then
  determines the extrinsic curvature from that, and writes it to a
  file.  Once you have it, you can go on as above.  CalcK has a small
  shell script that tells you what to do.


\item

  In general, things become more interesting if a static conformal
  factor is involved (since more variables are present), especially if
  it is output only once (since it is static), which means that one
  has to mix variables from different time steps.

\end{itemize}

The thorns involved in this procedure have some examples.  In general,
this is NOT a ``just do it'' action; you have to know what you are
doing, since you have to put the pieces together in your parameter
file and make sure that everything is consistent.  We may have a
vision that you just call a script in a directory that contains output
files and the script figures out everything else, but we're not there
yet.  All the ingredients are there, but you'll have to put them
together in the right way.  Think Lego.



\section{Interpreting 2D output}

2D output is given on a rectangular grid.  This grid has coordinates
which are regular and have a constant spacing in the $\theta$ and
$\phi$ directions.  Cactus output has only grid point indices, but
does not contain the coordinates $\theta$ and $\phi$ themselves.

In gnuplot, one can define functions to convert indices to
coordinates:
\begin{eqnarray}
  \theta(i) & = & (i - g\theta + 0.5) * \pi   / n\theta
  \\
  \phi(j)   & = & (j - g\phi        ) * 2*\pi / n\phi
\end{eqnarray}
where $g\theta$ and $g\phi$ is the number of ghost points in the
corresponding direction, and $n\theta$ and $n\phi$ the number of
interior points.  Here are the same equations in gnuplot syntax:
\begin{verbatim}
theta(i) = (i - nghosts + 0.5) * pi / ntheta
phi(j) = (j - nghosts) * 2*pi / nphi
\end{verbatim}

Usually, \verb|nghosts=2|, \verb|ntheta=35|, and \verb|nphi=72|.
\verb|i| and \verb|j| are is the integer grid point indices.  Note
that \verb|ntheta| and \verb|nphi| in the parameter file include ghost
zones, while their definitions here do not include them.  In general,
\verb|nphi| is even and \verb|ntheta| is odd, because the points are
staggered about the poles.

A test plot shows whether the plot is symmetric about $\pi/2$ in the
$\theta$ and $\pi$ in the $\phi$ direction.  Also, plotting something
axisymmetric with bitant symmetry vs.\ $\theta$ and vs.\ $\pi-\theta$,
and vs.\ $\phi$ and $2\pi-\phi$, should lie exactly on top of each
other.

There are also scalars \verb|origin/delta_theta/phi| which one can use
in the above equations.  Then the equations read
\begin{verbatim}
theta(i) = (i + origin_theta) * delta_theta
phi(j) = (j + origin_phi) * delta_phi
\end{verbatim}
but, of course, these four quantities are all irrational and don't
look nice.



\begin{thebibliography}{9}

\end{thebibliography}

% Do not delete next line
% END CACTUS THORNGUIDE

\end{document}

```



Reference answer:
src_code: #include "cctk.h"
#include "cctk_Arguments.h"
#include "cctk_Functions.h"
#include "cctk_Parameters.h"



subroutine qlm_calc_tetrad (CCTK_ARGUMENTS, hn)
  use adm_metric_simple
  use cctk
  use classify
  use matinv
  use pointwise2
  use qlm_boundary
  use qlm_derivs
  use qlm_gram_schmidt
  use qlm_variables
  use ricci4
  use tensor
  use tensor4
  implicit none
  DECLARE_CCTK_ARGUMENTS
  DECLARE_CCTK_FUNCTIONS
  DECLARE_CCTK_PARAMETERS
  integer :: hn
  
  CCTK_REAL, parameter :: one=1, two=2
  CCTK_REAL, parameter :: gg4(0:3,0:3,0:3) = 0
  CCTK_REAL    :: gg(3,3), dgg(3,3,3), gg_dot(3,3)
  CCTK_REAL    :: kk(3,3)
  CCTK_REAL    :: alfa, beta(3)
  CCTK_REAL    :: g4(0:3,0:3), gu4(0:3,0:3), dg4(0:3,0:3,0:3)
  CCTK_REAL    :: gamma4(0:3,0:3,0:3)
  CCTK_REAL    :: ee(0:3,0:3), ee_p(0:3,1:3), ee_p_p(0:3,1:3)
  CCTK_REAL    :: dee_spher(1:3,1:3,1:3), ee_inv(1:3,1:3)
  CCTK_REAL    :: dee(0:3,0:3,0:3), gee(0:3,0:3,0:3)
  CCTK_REAL    :: m1(0:3), m2(0:3) ! temporary variables to calculate mm
  CCTK_REAL    :: ss(0:3)          ! spacelike outward normal to horizon
  CCTK_REAL    :: tt(0:3)          ! timelike unit normal to hypersurface
  CCTK_REAL    :: ll(0:3)          ! future null vector on the horizon
  CCTK_REAL    :: nn(0:3)          ! future inward null vector
  CCTK_COMPLEX :: mm(0:3)          ! vector on horizon within the hypersurface
  CCTK_REAL    :: gtt(0:3,0:3), gss(0:3,0:3)
  CCTK_REAL    :: gm1(0:3,0:3), gm2(0:3,0:3)
  CCTK_REAL    :: gll(0:3,0:3), gnn(0:3,0:3)
  CCTK_COMPLEX :: gmm(0:3,0:3)
  CCTK_REAL    :: nabla_ll(0:3,0:3), nabla_nn(0:3,0:3)
  CCTK_COMPLEX :: nabla_mm(0:3,0:3)
  
  !CCTK_REAL    :: t0, t1, t2
  !logical      :: ce0, ce1, ce2
  CCTK_REAL    :: delta_space(2)
  
  CCTK_REAL    :: count, accuracy
  
  integer      :: lsh(2)
  integer      :: i, j
  integer      :: a, b, c, d
  CCTK_REAL    :: theta, phi
  
  logical      :: lerr
  
  character*2, parameter :: crlf = achar(13) // achar(10)
  character    :: msg*1000
  
  if (veryverbose/=0) then
     call CCTK_INFO ("Setting tetrad")
  end if
  
  lsh(:) = (/ qlm_ntheta(hn), qlm_nphi(hn) /)
  delta_space(:) = (/ qlm_delta_theta(hn), qlm_delta_phi(hn) /)
  
  count = 0
  accuracy = 0
  
  ! Calculate the coordinates
  do j = 1+qlm_nghostsphi(hn), qlm_nphi(hn)-qlm_nghostsphi(hn)
     do i = 1+qlm_nghoststheta(hn), qlm_ntheta(hn)-qlm_nghoststheta(hn)
        theta = qlm_origin_theta(hn) + (i-1)*qlm_delta_theta(hn)
        phi   = qlm_origin_phi(hn)   + (j-1)*qlm_delta_phi(hn)
        
        ! Get the variables from the arrays
        gg(1,1) = qlm_gxx(i,j)
        gg(1,2) = qlm_gxy(i,j)
        gg(1,3) = qlm_gxz(i,j)
        gg(2,2) = qlm_gyy(i,j)
        gg(2,3) = qlm_gyz(i,j)
        gg(3,3) = qlm_gzz(i,j)
        gg(2,1) = gg(1,2)
        gg(3,1) = gg(1,3)
        gg(3,2) = gg(2,3)
        
        dgg(1,1,1) = qlm_dgxxx(i,j)
        dgg(1,2,1) = qlm_dgxyx(i,j)
        dgg(1,3,1) = qlm_dgxzx(i,j)
        dgg(2,2,1) = qlm_dgyyx(i,j)
        dgg(2,3,1) = qlm_dgyzx(i,j)
        dgg(3,3,1) = qlm_dgzzx(i,j)
        dgg(2,1,1) = dgg(1,2,1)
        dgg(3,1,1) = dgg(1,3,1)
        dgg(3,2,1) = dgg(2,3,1)
        dgg(1,1,2) = qlm_dgxxy(i,j)
        dgg(1,2,2) = qlm_dgxyy(i,j)
        dgg(1,3,2) = qlm_dgxzy(i,j)
        dgg(2,2,2) = qlm_dgyyy(i,j)
        dgg(2,3,2) = qlm_dgyzy(i,j)
        dgg(3,3,2) = qlm_dgzzy(i,j)
        dgg(2,1,2) = dgg(1,2,2)
        dgg(3,1,2) = dgg(1,3,2)
        dgg(3,2,2) = dgg(2,3,2)
        dgg(1,1,3) = qlm_dgxxz(i,j)
        dgg(1,2,3) = qlm_dgxyz(i,j)
        dgg(1,3,3) = qlm_dgxzz(i,j)
        dgg(2,2,3) = qlm_dgyyz(i,j)
        dgg(2,3,3) = qlm_dgyzz(i,j)
        dgg(3,3,3) = qlm_dgzzz(i,j)
        dgg(2,1,3) = dgg(1,2,3)
        dgg(3,1,3) = dgg(1,3,3)
        dgg(3,2,3) = dgg(2,3,3)
        
        kk(1,1) = qlm_kxx(i,j)
        kk(1,2) = qlm_kxy(i,j)
        kk(1,3) = qlm_kxz(i,j)
        kk(2,2) = qlm_kyy(i,j)
        kk(2,3) = qlm_kyz(i,j)
        kk(3,3) = qlm_kzz(i,j)
        kk(2,1) = kk(1,2)
        kk(3,1) = kk(1,3)
        kk(3,2) = kk(2,3)
        
        alfa = qlm_alpha(i,j)
        
        beta(1) = qlm_betax(i,j)
        beta(2) = qlm_betay(i,j)
        beta(3) = qlm_betaz(i,j)
        
        
        
        ! Calculate 4-metric
        call calc_3metricdot_simple (kk, gg_dot)
        call calc_4metricderivs_simple (gg,dgg,gg_dot, g4,dg4)
        call calc_4inv (g4, gu4)
        call calc_4connections (gu4,dg4, gamma4)
        
        
        
        ee = TAT_nan()
        dee_spher = TAT_nan()
        dee = TAT_nan()
        
        
        
        ! Calculate the future timelike unit normal vector
        ! t^2 = -1
        ee(0,:) = (/ one, -beta /) / alfa
        dee(0,:,:) = 0
        
        
        
        ee(1,0) = 0
        ee(1,1) = qlm_x(i,j,hn) - qlm_origin_x(hn)
        ee(1,2) = qlm_y(i,j,hn) - qlm_origin_y(hn)
        ee(1,3) = qlm_z(i,j,hn) - qlm_origin_z(hn)
        
        !ee_p(1,1) = qlm_x_p(i,j,hn) - qlm_origin_x_p(hn)
        !ee_p(1,2) = qlm_y_p(i,j,hn) - qlm_origin_y_p(hn)
        !ee_p(1,3) = qlm_z_p(i,j,hn) - qlm_origin_z_p(hn)
        
        !ee_p_p(1,1) = qlm_x_p_p(i,j,hn) - qlm_origin_x_p_p(hn)
        !ee_p_p(1,2) = qlm_y_p_p(i,j,hn) - qlm_origin_y_p_p(hn)
        !ee_p_p(1,3) = qlm_z_p_p(i,j,hn) - qlm_origin_z_p_p(hn)
        
        dee(1,0,:) = 0
        !dee(1,1:3,0) = timederiv (ee(1,1:3), ee_p(1,1:3), ee_p_p(1,1:3), t0,t1,t2, ce0,ce1,ce2)
        dee(1,1:3,0) = 0
        dee_spher(1,:,1) = 0    ! this is a choice
        dee_spher(1,1,2:3) = deriv (qlm_x(:,:,hn), i,j, delta_space)
        dee_spher(1,2,2:3) = deriv (qlm_y(:,:,hn), i,j, delta_space)
        dee_spher(1,3,2:3) = deriv (qlm_z(:,:,hn), i,j, delta_space)
        
        
        
        ee(2:3,0) = 0
        ee(2:3,1) = deriv (qlm_x(:,:,hn), i,j, delta_space)
        ee(2:3,2) = deriv (qlm_y(:,:,hn), i,j, delta_space)
        ee(2:3,3) = deriv (qlm_z(:,:,hn), i,j, delta_space)
        
        ee_p(2:3,1) = deriv (qlm_x_p(:,:,hn), i,j, delta_space)
        ee_p(2:3,2) = deriv (qlm_y_p(:,:,hn), i,j, delta_space)
        ee_p(2:3,3) = deriv (qlm_z_p(:,:,hn), i,j, delta_space)
        
        ee_p_p(2:3,1) = deriv (qlm_x_p_p(:,:,hn), i,j, delta_space)
        ee_p_p(2:3,2) = deriv (qlm_y_p_p(:,:,hn), i,j, delta_space)
        ee_p_p(2:3,3) = deriv (qlm_z_p_p(:,:,hn), i,j, delta_space)
        
        dee(2:3,0,:) = 0
        !dee(2:3,1:3,0) = timederiv (ee(2:3,1:3), ee_p(2:3,1:3), ee_p_p(2:3,1:3), t0,t1,t2, ce0,ce1,ce2)
        dee(2:3,1:3,0) = 0
        dee_spher(2:3,:,1) = 0  ! this is a choice
        dee_spher(2:3,1,2:3) = deriv2 (qlm_x(:,:,hn), i,j, delta_space)
        dee_spher(2:3,2,2:3) = deriv2 (qlm_y(:,:,hn), i,j, delta_space)
        dee_spher(2:3,3,2:3) = deriv2 (qlm_z(:,:,hn), i,j, delta_space)
        
        ! ee_a^i
        ! dee_spher_a^i,b
        ! dee_a^i,j = ee_j^b dee_spher_a^i,b
        call calc_inv3 (ee(1:3,1:3), ee_inv, lerr)
        if (lerr) then
           call CCTK_WARN (3, "Could not invert matrix")
        end if
        do a=1,3
           do b=1,3
              do c=1,3
                 dee(a,b,c) = 0
                 do d=1,3
                    dee(a,b,c) = dee(a,b,c) + ee_inv(c,d) * dee_spher(a,b,d)
                 end do
              end do
           end do
        end do
        
        do a=0,3
           do b=0,3
              gee(:,a,b) = dee(:,a,b) 
              do c=0,3
                 gee(:,a,b) = gee(:,a,b) + ee(:,c) * gamma4(a,c,b)
              end do
           end do
        end do
        
        
        
        ! tt
        tt(:) = ee(0,:)
        gtt(:,:) = gee(0,:,:)
        
        ! m1 = ep
        m1(:) = ee(3,:)
        gm1(:,:) = gee(3,:,:)
        call gram_schmidt_normalise (g4,gg4, m1,gm1, one)
        
        ! m2 = et
        m2(:) = ee(2,:)
        gm2(:,:) = gee(2,:,:)
        call gram_schmidt_project (g4,gg4, m1,gm1, one, m2,gm2)
        call gram_schmidt_normalise (g4,gg4, m2,gm2, one)
        
        ! ss = er
        ss(:) = ee(1,:)
        gss(:,:) = gee(1,:,:)
        call gram_schmidt_project (g4,gg4, m1,gm1, one, ss,gss)
        call gram_schmidt_project (g4,gg4, m2,gm2, one, ss,gss)
        call gram_schmidt_normalise (g4,gg4, ss,gss, one)
        
        
        
        ! ll = (tt + ss) / sqrt(two)
        ll = (tt + ss) / sqrt(two)
        gll = (gtt + gss) / sqrt(two)
        
        ! nn = (tt - ss) / sqrt(two)
        nn = (tt - ss) / sqrt(two)
        gnn = (gtt - gss) / sqrt(two)
        
        ! mm = cmplx(m1, m2, kind(mm)) / sqrt(two)
        mm = cmplx(m1, m2, kind(mm)) / sqrt(two)
        gmm = cmplx(gm1, gm2, kind(gmm)) / sqrt(two)
        
        
        
        ! Store the stuff into the arrays
        do a=0,3
           do b=0,3
              nabla_ll(a,b) = 0
              nabla_nn(a,b) = 0
              nabla_mm(a,b) = 0
              do c=0,3
                 nabla_ll(a,b) = nabla_ll(a,b) + g4(a,c) * gll(c,b)
                 nabla_nn(a,b) = nabla_nn(a,b) + g4(a,c) * gnn(c,b)
                 nabla_mm(a,b) = nabla_mm(a,b) + g4(a,c) * gmm(c,b)
              end do
              qlm_tetrad_derivs(i,j)%nabla_ll(a,b) = nabla_ll(a,b)
              qlm_tetrad_derivs(i,j)%nabla_nn(a,b) = nabla_nn(a,b)
              qlm_tetrad_derivs(i,j)%nabla_mm(a,b) = nabla_mm(a,b)
           end do
        end do
        
        qlm_l0(i,j,hn) = ll(0)
        qlm_l1(i,j,hn) = ll(1)
        qlm_l2(i,j,hn) = ll(2)
        qlm_l3(i,j,hn) = ll(3)
        
        qlm_n0(i,j,hn) = nn(0)
        qlm_n1(i,j,hn) = nn(1)
        qlm_n2(i,j,hn) = nn(2)
        qlm_n3(i,j,hn) = nn(3)
        
        qlm_m0(i,j,hn) = mm(0)
        qlm_m1(i,j,hn) = mm(1)
        qlm_m2(i,j,hn) = mm(2)
        qlm_m3(i,j,hn) = mm(3)
        
     end do
  end do
  
  if (count > 0) then
     accuracy = sqrt(accuracy / count)
  end if
  
  if (veryverbose/=0) then
     write (msg, '("Tetrad accuracy L2 norm: ",g12.4)') accuracy
     call CCTK_INFO (msg)
  end if
  
!!$  if (accuracy > 1.0d-12) then
  if (accuracy > 1.0d-8) then
     call CCTK_WARN (1, "Tetrad is not accurate")
  end if
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_l0(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_l1(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_l2(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_l3(:,:,hn), +1)
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_n0(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_n1(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_n2(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_n3(:,:,hn), +1)
  
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_m0(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_m1(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_m2(:,:,hn), +1)
  call set_boundary (CCTK_PASS_FTOF, hn, qlm_m3(:,:,hn), +1)
  
end subroutine qlm_calc_tetrad