























































































































 


































































































































































 




























































































































































































 



















































 










 








































































































































































































































 










                                
                                

                                
                                

                                
                                

                                



















































































      subroutine DemoInterp_Interp2D(cctk_dim,cctk_gsh,cctk_lsh,cctk_lbn
     &d,cctk_ubnd,cctk_tile_min,cctk_tile_max,cctk_ash,cctk_alignment,cc
     &tk_alignment_offset,cctk_from,cctk_to,cctk_bbox,cctk_delta_time,cc
     &tk_time,cctk_delta_space,cctk_origin_space,cctk_levfac,cctk_levoff
     &,cctk_levoffdenom,cctk_timefac,cctk_convlevel,cctk_convfac,cctk_ng
     &hostzones,cctk_iteration,cctkGH,cctk_ash1,cctk_ash2,cctk_ash3, X0c
     &ompinterps,X0coordarrays,X0realinterps,compgf1,compgf2,compgf3,com
     &pinterp1,compinterp2,compinterp3,realgf1,realgf2,realgf3,realinter
     &p1,realinterp2,realinterp3,xcoord,ycoord,zcoord)

      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)
      INTEGER X0compinterps
      INTEGER X0coordarrays
      INTEGER X0realinterps
      COMPLEX*16 compgf1 (cctk_ash1)
      integer, parameter :: cctki_use_compgf1 = kind(compgf1)
      COMPLEX*16 compgf2 (cctk_ash1,cctk_ash2)
      integer, parameter :: cctki_use_compgf2 = kind(compgf2)
      COMPLEX*16 compgf3 (cctk_ash1,cctk_ash2,cctk_ash3)
      integer, parameter :: cctki_use_compgf3 = kind(compgf3)
      COMPLEX*16 compinterp1 (X0compinterps)
      integer, parameter :: cctki_use_compinterp1 = kind(compinterp1)
      COMPLEX*16 compinterp2 (X0compinterps)
      integer, parameter :: cctki_use_compinterp2 = kind(compinterp2)
      COMPLEX*16 compinterp3 (X0compinterps)
      integer, parameter :: cctki_use_compinterp3 = kind(compinterp3)
      REAL*8 realgf1 (cctk_ash1)
      integer, parameter :: cctki_use_realgf1 = kind(realgf1)
      REAL*8 realgf2 (cctk_ash1,cctk_ash2)
      integer, parameter :: cctki_use_realgf2 = kind(realgf2)
      REAL*8 realgf3 (cctk_ash1,cctk_ash2,cctk_ash3)
      integer, parameter :: cctki_use_realgf3 = kind(realgf3)
      REAL*8 realinterp1 (X0realinterps)
      integer, parameter :: cctki_use_realinterp1 = kind(realinterp1)
      REAL*8 realinterp2 (X0realinterps)
      integer, parameter :: cctki_use_realinterp2 = kind(realinterp2)
      REAL*8 realinterp3 (X0realinterps)
      integer, parameter :: cctki_use_realinterp3 = kind(realinterp3)
      REAL*8 xcoord (X0coordarrays)
      integer, parameter :: cctki_use_xcoord = kind(xcoord)
      REAL*8 ycoord (X0coordarrays)
      integer, parameter :: cctki_use_ycoord = kind(ycoord)
      REAL*8 zcoord (X0coordarrays)
      integer, parameter :: cctki_use_zcoord = kind(zcoord)
      REAL*8 interp_radius
      integer, parameter :: cctki_use_interp_radius = kind(interp_radius
     &)
      INTEGER*4 arrsize
      integer, parameter :: cctki_use_arrsize = kind(arrsize)
      INTEGER*4 interpolation_order
      integer, parameter :: cctki_use_interpolation_order = kind(interpo
     &lation_order)
      COMMON /DemoInterppriv/interp_radius, arrsize, interpolation_order
     &
      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 i
      integer ierror
      REAL*8 dth
      integer interp_handle, coord_system_handle, param_table_handle
      character(30) options_string
      integer*8, dimension(2) :: interp_coords
      INTEGER*4, dimension(2) :: in_array_indices
      integer*8, dimension(2) :: out_arrays
      INTEGER*4, dimension(2) :: out_array_type_codes

c
      dth = 2.0*atan(1.0)/real(arrsize)
      do i=1,arrsize
         xcoord(i) = interp_radius*cos(i*dth)
         ycoord(i) = interp_radius*sin(i*dth)
      end do

c
c
      param_table_handle = -1
      interp_handle = -1
      coord_system_handle = -1

      options_string = "order = " // char(ichar('0') + interpolation_ord
     &er)
      call Util_TableCreateFromString (param_table_handle, options_strin
     &g)
      if (param_table_handle .lt. 0) then
        call CCTK_Warn(0,39,"Interp2D.F","DemoInterp","Cannot create par
     &ameter table for interpolator")
      endif

      call CCTK_InterpHandle (interp_handle, "uniform cartesian")
      if (interp_handle < 0) then
        call CCTK_Warn(0,44,"Interp2D.F","DemoInterp","Cannot get handle
     & for interpolation ! Forgot to activate an implementation providin
     &g interpolation operators ??")
      end if

      call CCTK_CoordSystemHandle (coord_system_handle, "cart2d")
      if (coord_system_handle < 0) then
         call CCTK_Warn(0,49,"Interp2D.F","DemoInterp","Coordinate syste
     &m 'cart2d' not registered")
      end if

c
      interp_coords(1) = CCTK_PointerTo(xcoord)
      interp_coords(2) = CCTK_PointerTo(ycoord)

      call CCTK_VarIndex(i, "DemoInterp::realgf2")
      in_array_indices(1) = i
      call CCTK_VarIndex(i, "DemoInterp::compgf2")
      in_array_indices(2) = i

      out_array_type_codes(1) = 130
      out_array_type_codes(2) = 140

      out_arrays(1) = CCTK_PointerTo(realinterp2)
      out_arrays(2) = CCTK_PointerTo(compinterp2)

c
c
c

      call CCTK_InterpGridArrays (ierror, cctkGH, 2, interp_handle,
     .                            param_table_handle, coord_system_handl
     &e,
     .                            arrsize, 130, interp_coords,
     .                            2, in_array_indices,
     .                            2, out_array_type_codes, out_arrays)

      if (ierror<0) then
         call CCTK_Warn(1,78,"Interp2D.F","DemoInterp","Interpolation er
     &ror")
      endif

      print *
      print *,"Real 2D interpolation using CCTK_InterpGridArrays()"
      print *,"==================================================="
      print *,"Interpolated values should be ",interp_radius
      print *,"Actual values are : "
      do i=1,arrsize
         print *,realinterp2(i)
      end do

      print *
      print *,"Complex 2D interpolation using CCTK_InterpGridArrays()"
      print *,"======================================================"
      print *,"Interpolated values should be (",interp_radius,",",
     &     cos(interp_radius),")"
      print *,"Actual values are : "
      do i=1,arrsize
         print *,compinterp2(i)
      end do

      return
      end
