























































































































 


































































































































































 













































































































































































































 



















































 










 








































































































































































































































 










                                
                                

                                
                                

                                
                                

                                









































































      subroutine TestReduceF_Sum(cctk_dim,cctk_gsh,cctk_lsh,cctk_lbnd,cc
     &tk_ubnd,cctk_tile_min,cctk_tile_max,cctk_ash,cctk_alignment,cctk_a
     &lignment_offset,cctk_from,cctk_to,cctk_bbox,cctk_delta_time,cctk_t
     &ime,cctk_delta_space,cctk_origin_space,cctk_levfac,cctk_levoff,cct
     &k_levoffdenom,cctk_timefac,cctk_convlevel,cctk_convfac,cctk_nghost
     &zones,cctk_iteration,cctkGH,cctk_ash1,cctk_ash2,cctk_ash3, phi_gf1
     &,phi_gf2,phi_gf3,phi_igf1,phi_igf2,phi_igf3,phi_iscalar,phi_scalar
     &)

      implicit none


      INTEGER cctk_dim
      integer, parameter :: cctki_use_cctk_dim = kind(cctk_dim)
      INTEGER cctk_gsh (cctk_dim)
      integer, parameter :: cctki_use_cctk_gsh = kind(cctk_gsh)
      INTEGER cctk_lsh (cctk_dim)
      integer, parameter :: cctki_use_cctk_lsh = kind(cctk_lsh)
      INTEGER cctk_lbnd (cctk_dim)
      integer, parameter :: cctki_use_cctk_lbnd = kind(cctk_lbnd)
      INTEGER cctk_ubnd (cctk_dim)
      integer, parameter :: cctki_use_cctk_ubnd = kind(cctk_ubnd)
      INTEGER cctk_tile_min (cctk_dim)
      integer, parameter :: cctki_use_cctk_tile_min = kind(cctk_tile_min
     &)
      INTEGER cctk_tile_max (cctk_dim)
      integer, parameter :: cctki_use_cctk_tile_max = kind(cctk_tile_max
     &)
      INTEGER cctk_ash (cctk_dim)
      integer, parameter :: cctki_use_cctk_ash = kind(cctk_ash)
      INTEGER cctk_alignment
      integer, parameter :: cctki_use_cctk_alignment = kind(cctk_alignme
     &nt)
      INTEGER cctk_alignment_offset
      integer, parameter :: cctki_use_cctk_alignment_offset = kind(cctk_
     &alignment_offset)
      INTEGER cctk_from (cctk_dim)
      integer, parameter :: cctki_use_cctk_from = kind(cctk_from)
      INTEGER cctk_to (cctk_dim)
      integer, parameter :: cctki_use_cctk_to = kind(cctk_to)
      INTEGER cctk_bbox (2*cctk_dim)
      integer, parameter :: cctki_use_cctk_bbox = kind(cctk_bbox)
      REAL*8 cctk_delta_time
      integer, parameter :: cctki_use_cctk_delta_time = kind(cctk_delta_
     &time)
      REAL*8 cctk_time
      integer, parameter :: cctki_use_cctk_time = kind(cctk_time)
      REAL*8 cctk_delta_space (cctk_dim)
      integer, parameter :: cctki_use_cctk_delta_space = kind(cctk_delta
     &_space)
      REAL*8 cctk_origin_space (cctk_dim)
      integer, parameter :: cctki_use_cctk_origin_space = kind(cctk_orig
     &in_space)
      INTEGER cctk_levfac (cctk_dim)
      integer, parameter :: cctki_use_cctk_levfac = kind(cctk_levfac)
      INTEGER cctk_levoff (cctk_dim)
      integer, parameter :: cctki_use_cctk_levoff = kind(cctk_levoff)
      INTEGER cctk_levoffdenom (cctk_dim)
      integer, parameter :: cctki_use_cctk_levoffdenom = kind(cctk_levof
     &fdenom)
      INTEGER cctk_timefac
      integer, parameter :: cctki_use_cctk_timefac = kind(cctk_timefac)
      INTEGER cctk_convlevel
      integer, parameter :: cctki_use_cctk_convlevel = kind(cctk_convlev
     &el)
      INTEGER cctk_convfac
      integer, parameter :: cctki_use_cctk_convfac = kind(cctk_convfac)
      INTEGER cctk_nghostzones (cctk_dim)
      integer, parameter :: cctki_use_cctk_nghostzones = kind(cctk_nghos
     &tzones)
      INTEGER cctk_iteration
      integer, parameter :: cctki_use_cctk_iteration = kind(cctk_iterati
     &on)
      integer*8 cctkGH
      integer, parameter :: cctki_use_cctkGH = kind(cctkGH)
      INTEGER cctk_ash1
      integer, parameter :: cctki_use_cctk_ash1 = kind(cctk_ash1)
      INTEGER cctk_ash2
      integer, parameter :: cctki_use_cctk_ash2 = kind(cctk_ash2)
      INTEGER cctk_ash3
      integer, parameter :: cctki_use_cctk_ash3 = kind(cctk_ash3)
      REAL*8 phi_gf1 (cctk_ash1)
      integer, parameter :: cctki_use_phi_gf1 = kind(phi_gf1)
      REAL*8 phi_gf2 (cctk_ash1,cctk_ash2)
      integer, parameter :: cctki_use_phi_gf2 = kind(phi_gf2)
      REAL*8 phi_gf3 (cctk_ash1,cctk_ash2,cctk_ash3)
      integer, parameter :: cctki_use_phi_gf3 = kind(phi_gf3)
      INTEGER*4 phi_igf1 (cctk_ash1)
      integer, parameter :: cctki_use_phi_igf1 = kind(phi_igf1)
      INTEGER*4 phi_igf2 (cctk_ash1,cctk_ash2)
      integer, parameter :: cctki_use_phi_igf2 = kind(phi_igf2)
      INTEGER*4 phi_igf3 (cctk_ash1,cctk_ash2,cctk_ash3)
      integer, parameter :: cctki_use_phi_igf3 = kind(phi_igf3)
      INTEGER*4 phi_iscalar
      integer, parameter :: cctki_use_phi_iscalar = kind(phi_iscalar)
      REAL*8 phi_scalar
      integer, parameter :: cctki_use_phi_scalar = kind(phi_scalar)
      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

      integer handle
      integer index
      integer ierr
      REAL*8 reduction_value
      INTEGER*4 ireduction_value
      
      call CCTK_Info("TestReduce","TESTING SUM REDUCTIONS FROM FORTRAN")
     &

c

      call CCTK_VarIndex(index,"TestReduce::phi_gf3")
      call CCTK_ReductionHandle(handle,"sum")

      if (handle .gt. 0) then
	 call CCTK_Reduce (ierr,cctkGH, 
     &        0,handle, 1, 
     &        130,
     &        CCTK_PointerTo (reduction_value),
     &        1,index)
         if (ierr .eq. 0 .and. CCTK_MyProc(cctkGH).eq.0) then
            print *,"Sum value of phi_gf3 is ",reduction_value
         end if
      else
         call CCTK_Warn(1,35,"Reduce_Sum.F77","TestReduce","TestReduce: 
     &Invalid reduction operator")
      end if
      
      call CCTK_VarIndex(index,"TestReduce::phi_igf3")
      call CCTK_ReductionHandle(handle,"sum")

      if (handle .gt. 0) then
	 call CCTK_Reduce (ierr,cctkGH, 
     &        0,handle, 1, 
     &        120,
     &        CCTK_PointerTo (ireduction_value),
     &        1,index)
         if (ierr .eq. 0 .and. CCTK_MyProc(cctkGH).eq.0) then
            print *,"Sum value of phi_igf3 is ",ireduction_value
         end if
      else
         call CCTK_Warn(1,51,"Reduce_Sum.F77","TestReduce","TestReduce: 
     &Invalid reduction operator")
      end if
      
c

      call CCTK_VarIndex(index,"TestReduce::phi_gf2")      
      call CCTK_ReductionHandle(handle,"sum")

      if (handle .gt. 0) then
         call CCTK_Reduce (ierr,cctkGH,0, 
     &        handle,1, 
     &        130,
     &        CCTK_PointerTo (reduction_value),
     &        1,index)
         if (ierr .eq. 0 .and. CCTK_MyProc(cctkGH).eq.0) then
            print *,"Sum value of phi_gf2 is",reduction_value
         end if
      else
         call CCTK_Warn(1,69,"Reduce_Sum.F77","TestReduce","TestReduce: 
     &Invalid reduction operator")
      end if

      call CCTK_VarIndex(index,"TestReduce::phi_igf2")      
      call CCTK_ReductionHandle(handle,"sum")

      if (handle .gt. 0) then
         call CCTK_Reduce (ierr,cctkGH,0, 
     &        handle,1, 
     &        120,
     &        CCTK_PointerTo (ireduction_value),
     &        1,index)
         if (ierr .eq. 0 .and. CCTK_MyProc(cctkGH).eq.0) then
            print *,"Sum value of phi_igf2 is",ireduction_value
         end if
      else
         call CCTK_Warn(1,85,"Reduce_Sum.F77","TestReduce","TestReduce: 
     &Invalid reduction operator")
      end if


c

      call CCTK_VarIndex(index,"TestReduce::phi_gf1")
      call CCTK_ReductionHandle(handle,"sum")

      if (handle .gt. 0) then
         call CCTK_Reduce (ierr,cctkGH,0, 
     &        handle,1, 
     &        130,
     &        CCTK_PointerTo (reduction_value),
     &        1,index)
         if (ierr .eq. 0 .and. CCTK_MyProc(cctkGH).eq.0) then
            print *,"Sum value of phi_gf1 is",reduction_value
         end if
      else
         call CCTK_Warn(1,104,"Reduce_Sum.F77","TestReduce","TestReduce:
     & Invalid reduction operator")
      end if

      call CCTK_VarIndex(index,"TestReduce::phi_igf1")
      call CCTK_ReductionHandle(handle,"sum")

      if (handle .gt. 0) then
         call CCTK_Reduce (ierr,cctkGH,0, 
     &        handle,1, 
     &        120,
     &        CCTK_PointerTo (ireduction_value),
     &        1,index)
         if (ierr .eq. 0 .and. CCTK_MyProc(cctkGH) .eq. 0) then
            print *,"Sum value of phi_igf1 is",ireduction_value
         end if
      else
         call CCTK_Warn(1,120,"Reduce_Sum.F77","TestReduce","TestReduce:
     & Invalid reduction operator")
      end if

c

      call CCTK_VarIndex(index,"TestReduce::phi_scalar")  
      call CCTK_ReductionHandle(handle,"sum")

      if (handle .gt. 0) then
         call CCTK_Reduce (ierr,cctkGH, 
     &        0,handle,1, 
     &        130,
     &        CCTK_PointerTo (reduction_value),
     &        1,index)
         if (ierr .eq. 0 .and. CCTK_MyProc(cctkGH).eq.0) then
            print *,"Sum value of phi_scalar is ",reduction_value
         end if
      else
         call CCTK_Warn(1,138,"Reduce_Sum.F77","TestReduce","TestReduce:
     & Invalid reduction operator")
      end if

      call CCTK_VarIndex(index,"TestReduce::phi_iscalar")  
      call CCTK_ReductionHandle(handle,"sum")

      if (handle .gt. 0) then
         call CCTK_Reduce (ierr,cctkGH, 
     &        0,handle,1, 
     &        120,
     &        CCTK_PointerTo (ireduction_value),
     &        1,index)
         if (ierr .eq. 0 .and. CCTK_MyProc(cctkGH).eq.0) then
            print *,"Sum value of phi_scalar is ",ireduction_value
         end if
      else
         call CCTK_Warn(1,154,"Reduce_Sum.F77","TestReduce","TestReduce:
     & Invalid reduction operator")
      end if

      return
      end

