






















































































































 


































































































































































 



















































































































































































































 





















































































 










 








































































































































































































































 










                                
                                

                                
                                

                                
                                

                                



















































































subroutine NoExcision_Reduce (cctk_iteration, cctk_lsh, rhs, x, y, z)
  implicit none
  interface
  integer*8 function CCTK_PointerTo (var)
  implicit none
  type(*),dimension(..),TARGET :: var
  end function CCTK_PointerTo
  end interface
  interface
  integer function CCTK_Equals (arg1, arg2)
  implicit none
  integer*8 arg1
  character(*) arg2
  end function CCTK_Equals
  integer function CCTK_MyProc (cctkGH)
  implicit none
  integer*8 cctkGH
  end function CCTK_MyProc
  integer function CCTK_nProcs (cctkGH)
  implicit none
  integer*8 cctkGH
  end function CCTK_nProcs
  integer function CCTK_IsThornActive (name)
  implicit none
  character(*) name
  end function CCTK_IsThornActive
  integer*8 function CCTK_NullPointer ()
  implicit none
  end function CCTK_NullPointer
  end interface
  interface
  INTEGER*4 function Boundary_SelectGroupForBC (GH, faces, boundary_width, table_handle, var_name, bc_name)
  implicit none
  integer*8 GH
  INTEGER*4 faces
  INTEGER*4 boundary_width
  INTEGER*4 table_handle
  character(*) var_name
  character(*) bc_name
  end function Boundary_SelectGroupForBC
  end interface
  interface
  INTEGER*4 function MoLQueryEvolvedRHS (EvolvedIndex)
  implicit none
  INTEGER*4 EvolvedIndex
  end function MoLQueryEvolvedRHS
  end interface
  REAL*8 Minkowski_scale (10)
  integer, parameter :: cctki_use_Minkowski_scale = kind(Minkowski_scale)
  REAL*8 centre_x (10)
  integer, parameter :: cctki_use_centre_x = kind(centre_x)
  REAL*8 centre_y (10)
  integer, parameter :: cctki_use_centre_y = kind(centre_y)
  REAL*8 centre_z (10)
  integer, parameter :: cctki_use_centre_z = kind(centre_z)
  REAL*8 lapse_scale (10)
  integer, parameter :: cctki_use_lapse_scale = kind(lapse_scale)
  REAL*8 radius (10)
  integer, parameter :: cctki_use_radius = kind(radius)
  REAL*8 radius_x (10)
  integer, parameter :: cctki_use_radius_x = kind(radius_x)
  REAL*8 radius_y (10)
  integer, parameter :: cctki_use_radius_y = kind(radius_y)
  REAL*8 radius_z (10)
  integer, parameter :: cctki_use_radius_z = kind(radius_z)
  REAL*8 reduction_factor (10)
  integer, parameter :: cctki_use_reduction_factor = kind(reduction_factor)
  REAL*8 smoothing_eps
  integer, parameter :: cctki_use_smoothing_eps = kind(smoothing_eps)
  REAL*8 smoothing_factor
  integer, parameter :: cctki_use_smoothing_factor = kind(smoothing_factor)
  REAL*8 smoothing_zone_width (10)
  integer, parameter :: cctki_use_smoothing_zone_width = kind(smoothing_zone_width)
  integer*8 method
  integer, parameter :: cctki_use_method = kind(method)
  integer*8 region_shape (10)
  integer, parameter :: cctki_use_region_shape = kind(region_shape)
  integer*8 smoothing_function (10)
  integer, parameter :: cctki_use_smoothing_function = kind(smoothing_function)
  INTEGER*4 num_regions
  integer, parameter :: cctki_use_num_regions = kind(num_regions)
  INTEGER*4 overwrite_geometry (10)
  integer, parameter :: cctki_use_overwrite_geometry = kind(overwrite_geometry)
  INTEGER*4 overwrite_lapse (10)
  integer, parameter :: cctki_use_overwrite_lapse = kind(overwrite_lapse)
  INTEGER*4 overwrite_shift (10)
  integer, parameter :: cctki_use_overwrite_shift = kind(overwrite_shift)
  INTEGER*4 reduce_rhs (10)
  integer, parameter :: cctki_use_reduce_rhs = kind(reduce_rhs)
  INTEGER*4 smooth_regions
  integer, parameter :: cctki_use_smooth_regions = kind(smooth_regions)
  INTEGER*4 smoothing_iterations
  integer, parameter :: cctki_use_smoothing_iterations = kind(smoothing_iterations)
  INTEGER*4 smoothing_order
  integer, parameter :: cctki_use_smoothing_order = kind(smoothing_order)
  INTEGER*4 surface_index (10)
  integer, parameter :: cctki_use_surface_index = kind(surface_index)
  INTEGER*4 use_user_regions
  integer, parameter :: cctki_use_use_user_regions = kind(use_user_regions)
  INTEGER*4 verbose
  integer, parameter :: cctki_use_verbose = kind(verbose)
  COMMON /NoExcisionpriv/Minkowski_scale, centre_x, centre_y, centre_z, lapse_scale, radius, radius_x, radius_y, radius_z, reductio&
  &n_factor, smoothing_eps, smoothing_factor, smoothing_zone_width, method, region_shape, smoothing_function, num_regions, overwrit&
  &e_geometry, overwrite_lapse, overwrite_shift, reduce_rhs, smooth_regions, smoothing_iterations, smoothing_order, surface_index, &
  &use_user_regions, verbose
  
  integer :: cctk_iteration
  integer :: cctk_lsh(3)
  REAL*8, dimension(cctk_lsh(1),cctk_lsh(2),cctk_lsh(3)) :: rhs, x, y, z
  
  REAL*8, parameter :: zero=0
  REAL*8, dimension(cctk_lsh(1),cctk_lsh(2),cctk_lsh(3)) :: dist2
  REAL*8 :: cx, cy, cz, radx, rady, radz, width
  integer   :: n
  
  integer, parameter :: sm_linear = 1
  integer, parameter :: sm_spline = 2
  integer :: sm_type
  
  do n = 1, num_regions
     if (reduce_rhs(n) /= 0) then

        cx = centre_x(n)
        cy = centre_y(n)
        cz = centre_z(n)
        if ((CCTK_Equals(region_shape(n), "sphere") .ne. 0)) then
           radx = radius(n)
           rady = radius(n)
           radz = radius(n)
        else if ((CCTK_Equals(region_shape(n), "ellipsoid") .ne. 0)) then
           radx = radius_x(n)
           rady = radius_y(n)
           radz = radius_z(n)
        else
           call CCTK_Warn(0,41,"reduce.F90","NoExcision", "internal error")
        end if

        if ((CCTK_Equals(smoothing_function(n), "linear") .ne. 0)) then
           sm_type = sm_linear
        else if ((CCTK_Equals(smoothing_function(n), "spline") .ne. 0)) then
           sm_type = sm_spline
        else
           call CCTK_Warn(0,49,"reduce.F90","NoExcision", "internal error")
        end if
        width = smoothing_zone_width(n)

        dist2 = (x - cx)**2 + (y - cy)**2 + (z - cz)**2

        
        
        where (dist2 <= 1)
           rhs = smooth (rhs, rhs * reduction_factor(n), dist2)
        end where
        
     end if
  end do
  
contains
  
  elemental function smooth (oldval, goodval, dist2) result (newval)
    REAL*8             :: newval
    REAL*8, intent(in) :: oldval
    REAL*8, intent(in) :: goodval
    REAL*8, intent(in) :: dist2
    
    REAL*8, parameter :: two=2, half=1/two
    REAL*8 :: dist
    REAL*8 :: x, f
    
    if (dist2 <= (1 - width)**2) then
       newval = goodval
    else if (width == 0 .or. dist2 >= 1) then
       newval = oldval
    else
       dist = sqrt(dist2)
       x = 1 - (1 - dist) / width
       select case (sm_type)
       case (sm_linear)
          f = x
       case (sm_spline)
          if (x < half) then
             f = 2 * x**2
          else
             f = 1 - 2 * (1-x)**2
          end if
       end select
       newval = oldval * f + goodval * (1 - f)
    end if
    
  end function smooth
  
end subroutine NoExcision_Reduce
