























































































































 


































































































































































 






























































































































































































 





















































 










 








































































































































































































































 










                                
                                

                                
                                

                                
                                

                                









































module cctk_core
  implicit none

  
  type, bind(C) :: cGH
     integer cctk_dim
     integer cctk_iteration

     integer*8 cctk_gsh_ptr
     integer*8 cctk_lsh_ptr
     integer*8 cctk_lbnd_ptr
     integer*8 cctk_ubnd_ptr

     integer*8 cctk_ash_ptr
     integer cctk_alignment, cctk_alignment_offset
  end type cGH

contains

  pure function cctki_array_index(array, idx) result(value)
    implicit none
    integer*8, intent(in) :: array
    integer, intent(in) :: idx
    integer values(idx)
    pointer (array, values)
    integer value
    value = values(idx)
  end function cctki_array_index

  pure function cctki_array(array, dim) result(values)
    implicit none
    integer*8, intent(in) :: array
    integer, intent(in) :: dim
    integer array_values(dim)
    pointer (array, array_values)
    integer values(dim)
    values = array_values
  end function cctki_array

end module cctk_core



module cctk_core2
  use cctk
  use cctk_core
  implicit none

contains

  pure function cctki_ash(cctkGH, idx) result(value)
    implicit none
    integer*8, intent(in) :: cctkGH
    type(cGH) cctkGH_value
    pointer (cctkGH, cctkGH_value)
    integer, intent(in) :: idx
    integer value
    value = cctki_array_index(cctkGH_value % cctk_ash_ptr, idx)
  end function cctki_ash

  
  
  
  
  
  
  
  
  

  pure function cctki_group_ash(cctkGH, groupname, dim, idx) result(value)
    implicit none
    integer*8, intent(in) :: cctkGH
    character(*), intent(in) :: groupname
    integer, intent(in) :: dim
    integer, intent(in) :: idx
    integer value
    integer ash(dim)
    integer ierr
    call CCTK_GroupashGN(ierr, cctkGH, dim, ash, groupname)
    value = ash(idx)
  end function cctki_group_ash

end module cctk_core2



subroutine TestFortranCrayPointers_callee(cctkGH)
  use cctk
  use cctk_core
  use cctk_core2
  implicit none

  integer*8 cctkGH
  type(cGH) cctkGH_value
  pointer (cctkGH, cctkGH_value)

  integer cctki_dim
  integer cctk_lsh
  cctk_lsh(cctki_dim) = &
       cctki_array_index(cctkGH_value % cctk_lsh_ptr, cctki_dim)

  integer, save :: cctki_varindex_gf = -1
  integer*8 gf_ptr
  REAL*8 gf(cctki_ash(cctkGH, 1), cctki_ash(cctkGH, 2), cctki_ash(cctkGH, 3))
  pointer (gf_ptr, gf)

  integer, save :: cctki_varindex_ga = -1
  integer*8 ga_ptr
  REAL*8 ga(cctki_group_ash(cctkGH, "TestFortranCrayPointers::ga", 2, 1), &
       cctki_group_ash(cctkGH, "TestFortranCrayPointers::ga", 2, 2))
  pointer (ga_ptr, ga)

  integer, save :: cctki_varindex_gs = -1
  integer*8 gs_ptr
  REAL*8 gs
  pointer (gs_ptr, gs)

  integer ga_lsh(2)

  integer i, j, k
  integer ierr

  if (cctki_varindex_gf < 0) then
     call CCTK_VarIndex(cctki_varindex_gf, "TestFortranCrayPointers::gf")
  end if
  call CCTK_VarDataPtrI(gf_ptr, cctkGH, 0, cctki_varindex_gf)

  if (cctki_varindex_ga < 0) then
     call CCTK_VarIndex(cctki_varindex_ga, "TestFortranCrayPointers::ga")
  end if
  call CCTK_VarDataPtrI(ga_ptr, cctkGH, 0, cctki_varindex_ga)

  if (cctki_varindex_gs < 0) then
     call CCTK_VarIndex(cctki_varindex_gs, "TestFortranCrayPointers::gs")
  end if
  call CCTK_VarDataPtrI(gs_ptr, cctkGH, 0, cctki_varindex_gs)

  do k = 1, cctk_lsh(3)
     do j = 1, cctk_lsh(2)
        do i = 1, cctk_lsh(1)
           gf(i,j,k) = 1
        end do
     end do
  end do

  call CCTK_GrouplshGN(ierr, cctkGH, 2, ga_lsh, "TestFortranCrayPointers::ga")
  if (ierr < 0) then
     call CCTK_Error(154,"calling.F90","TestFortranCrayPointers","Cannot determine ga_lsh")
  end if

  do j = 1, ga_lsh(2)
     do i = 1, ga_lsh(1)
        ga(i,j) = 1
     end do
  end do

  gs = 1
end subroutine TestFortranCrayPointers_callee



subroutine TestFortranCrayPointers_caller(cctk_dim,cctk_gsh,cctk_lsh,cctk_lbnd,cctk_ubnd,cctk_tile_min,cctk_tile_max,cctk_ash,cctk_&
  &alignment,cctk_alignment_offset,cctk_from,cctk_to,cctk_bbox,cctk_delta_time,cctk_time,cctk_delta_space,cctk_origin_space,cctk_le&
  &vfac,cctk_levoff,cctk_levoffdenom,cctk_timefac,cctk_convlevel,cctk_convfac,cctk_nghostzones,cctk_iteration,cctkGH,cctk_ash1,cctk&
  &_ash2,cctk_ash3, X0ga,X1ga,ga,gf,gs)
  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_alignment)
  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_origin_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_levoffdenom)
  INTEGER cctk_timefac
  integer, parameter :: cctki_use_cctk_timefac = kind(cctk_timefac)
  INTEGER cctk_convlevel
  integer, parameter :: cctki_use_cctk_convlevel = kind(cctk_convlevel)
  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_nghostzones)
  INTEGER cctk_iteration
  integer, parameter :: cctki_use_cctk_iteration = kind(cctk_iteration)
  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 X0ga
  INTEGER X1ga
  REAL*8 ga (X0ga,X1ga)
  integer, parameter :: cctki_use_ga = kind(ga)
  REAL*8 gf (cctk_ash1,cctk_ash2,cctk_ash3)
  integer, parameter :: cctki_use_gf = kind(gf)
  REAL*8 gs
  integer, parameter :: cctki_use_gs = kind(gs)
  gf = 0
  ga = 0
  gs = 0
  call TestFortranCrayPointers_callee(cctkGH)
  if (any(gf /= 1) .or. any(ga /= 1) .or. gs /= 1) then
     call CCTK_Error(176,"calling.F90","TestFortranCrayPointers","Grid variables are incorrect")
  end if
end subroutine TestFortranCrayPointers_caller
