libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-3.f90

   1 ! { dg-do run }
   2 ! Check whether absent optional arguments are properly
   3 ! handled with use_device_{addr,ptr}.
   4 program main
   5   use iso_c_binding, only: c_ptr, c_loc, c_associated, c_f_pointer
   6   implicit none (type, external)
   7
   8   integer, target :: u
   9   integer, target :: v
  10   integer, target :: w
  11   integer, target :: x(4)
  12   integer, target, allocatable :: y
  13   integer, target, allocatable :: z(:)
  14   type(c_ptr), target :: cptr
  15   type(c_ptr), target :: cptr_in
  16   integer :: dummy
  17
  18   u = 42
  19   v = 5
  20   w = 7
  21   x = [3,4,6,2]
  22   y = 88
  23   z = [1,2,3]
  24
  25   !$omp target enter data map(to:u)
  26   !$omp target data map(to:dummy) use_device_addr(u)
  27    cptr_in = c_loc(u) ! Has to be outside 'foo' due to 'intent(in)'
  28   !$omp end target data
  29
  30   call foo (u, v, w, x, y, z, cptr, cptr_in)
  31   deallocate (y, z)
  32 contains
  33   subroutine foo (u, v, w, x, y, z, cptr, cptr_in)
  34     integer, target, optional, value :: v
  35     integer, target, optional :: u, w
  36     integer, target, optional :: x(:)
  37     integer, target, optional, allocatable :: y
  38     integer, target, optional, allocatable :: z(:)
  39     type(c_ptr), target, optional, value :: cptr
  40     type(c_ptr), target, optional, value, intent(in) :: cptr_in
  41     integer :: d
  42
  43     type(c_ptr) :: p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in
  44
  45     !$omp target enter data map(to:w, x, y, z)
  46     !$omp target data map(dummy) use_device_addr(x)
  47       cptr = c_loc(x)
  48     !$omp end target data
  49
  50     ! Need to map per-VALUE arguments, if present
  51     if (present(v)) then
  52       !$omp target enter data map(to:v)
  53     else
  54       stop 1
  55     end if
  56     if (present(cptr)) then
  57       !$omp target enter data map(to:cptr)
  58     else
  59       stop 2
  60     end if
  61     if (present(cptr_in)) then
  62       !$omp target enter data map(to:cptr_in)
  63     else
  64       stop 3
  65     end if
  66
  67     !$omp target data map(d) use_device_addr(u, v, w, x, y, z)
  68     !$omp target data map(d) use_device_addr(cptr, cptr_in)
  69       if (.not. present(u)) stop 10
  70       if (.not. present(v)) stop 11
  71       if (.not. present(w)) stop 12
  72       if (.not. present(x)) stop 13
  73       if (.not. present(y)) stop 14
  74       if (.not. present(z)) stop 15
  75       if (.not. present(cptr)) stop 16
  76       if (.not. present(cptr_in)) stop 17
  77       p_u = c_loc(u)
  78       p_v = c_loc(v)
  79       p_w = c_loc(w)
  80       p_x = c_loc(x)
  81       p_y = c_loc(y)
  82       p_z = c_loc(z)
  83       p_cptr = c_loc(cptr)
  84       p_cptr_in = c_loc(cptr_in)
  85     !$omp end target data
  86     !$omp end target data
  87     call check(p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in, size(x), size(z))
  88   end subroutine foo
  89
  90   subroutine check(p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in, Nx, Nz)
  91     type(c_ptr), value :: p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in
  92     integer, value :: Nx, Nz
  93     integer, pointer :: c_u(:), c_v(:), c_w(:), c_x(:), c_y(:), c_z(:)
  94     type(c_ptr), pointer :: c_cptr(:), c_cptr_in(:)
  95
  96     ! As is_device_ptr does not handle scalars, we map them to a size-1 array
  97     call c_f_pointer(p_u, c_u, shape=[1])
  98     call c_f_pointer(p_v, c_v, shape=[1])
  99     call c_f_pointer(p_w, c_w, shape=[1])
 100     call c_f_pointer(p_x, c_x, shape=[Nx])
 101     call c_f_pointer(p_y, c_y, shape=[1])
 102     call c_f_pointer(p_z, c_z, shape=[Nz])
 103     call c_f_pointer(p_cptr, c_cptr, shape=[1])
 104     call c_f_pointer(p_cptr_in, c_cptr_in, shape=[1])
 105     call run_target(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz)
 106   end subroutine check
 107
 108   subroutine run_target(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz)
 109     integer, target :: c_u(:), c_v(:), c_w(:), c_x(:), c_y(:), c_z(:)
 110     type(c_ptr) :: c_cptr(:), c_cptr_in(:)
 111     integer, value :: Nx, Nz
 112     !$omp target is_device_ptr(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in) map(to:Nx, Nz)
 113       call target_fn(c_u(1), c_v(1), c_w(1), c_x, c_y(1), c_z, c_cptr(1), c_cptr_in(1), Nx, Nz)
 114     !$omp end target
 115   end subroutine run_target
 116
 117   subroutine target_fn(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz)
 118     !$omp declare target
 119     integer, target :: c_u, c_v, c_w, c_x(:), c_y, c_z(:)
 120     type(c_ptr), value :: c_cptr, c_cptr_in
 121     integer, value :: Nx, Nz
 122     integer, pointer :: u, x(:)
 123     if (c_u /= 42) stop 30
 124     if (c_v /= 5) stop 31
 125     if (c_w /= 7) stop 32
 126     if (Nx /= 4) stop 33
 127     if (any (c_x /= [3,4,6,2])) stop 34
 128     if (c_y /= 88) stop 35
 129     if (Nz /= 3) stop 36
 130     if (any (c_z /= [1,2,3])) stop 37
 131     if (.not. c_associated (c_cptr)) stop 38
 132     if (.not. c_associated (c_cptr_in)) stop 39
 133     if (.not. c_associated (c_cptr, c_loc(c_x))) stop 40
 134     if (.not. c_associated (c_cptr_in, c_loc(c_u))) stop 41
 135     call c_f_pointer(c_cptr_in, u)
 136     call c_f_pointer(c_cptr, x, shape=[Nx])
 137     if (u /= c_u .or. u /= 42)  stop 42
 138     if (any (x /= c_x))  stop 43
 139     if (any (x /= [3,4,6,2]))  stop 44
 140   end subroutine target_fn
 141 end program main