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

! { dg-do run }
! { dg-additional-options "-Wno-deprecated-openmp" }
! Check whether absent optional arguments are properly
! handled with use_device_{addr,ptr}.
program main
  use iso_c_binding, only: c_ptr, c_loc, c_associated, c_f_pointer
  implicit none (type, external)

  integer, target :: u
  integer, target :: v
  integer, target :: w
  integer, target :: x(4)
  integer, target, allocatable :: y
  integer, target, allocatable :: z(:)
  type(c_ptr), target :: cptr
  type(c_ptr), target :: cptr_in
  integer :: dummy

  u = 42
  v = 5
  w = 7
  x = [3,4,6,2]
  y = 88
  z = [1,2,3]

  !$omp target enter data map(to:u)
  !$omp target data map(to:dummy) use_device_addr(u)
   cptr_in = c_loc(u) ! Has to be outside 'foo' due to 'intent(in)'
  !$omp end target data

  call foo (u, v, w, x, y, z, cptr, cptr_in)
  deallocate (y, z)
contains
  subroutine foo (u, v, w, x, y, z, cptr, cptr_in)
    integer, target, optional, value :: v
    integer, target, optional :: u, w
    integer, target, optional :: x(:)
    integer, target, optional, allocatable :: y
    integer, target, optional, allocatable :: z(:)
    type(c_ptr), target, optional, value :: cptr
    type(c_ptr), target, optional, value, intent(in) :: cptr_in
    integer :: d

    type(c_ptr) :: p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in

    !$omp target enter data map(to:w, x, y, z)
    !$omp target data map(dummy) use_device_addr(x)
      cptr = c_loc(x)
    !$omp end target data

    ! Need to map per-VALUE arguments, if present
    if (present(v)) then
      !$omp target enter data map(to:v)
    else
      stop 1
    end if
    if (present(cptr)) then
      !$omp target enter data map(to:cptr)
    else
      stop 2
    end if
    if (present(cptr_in)) then
      !$omp target enter data map(to:cptr_in)
    else
      stop 3
    end if

    !$omp target data map(d) use_device_addr(u, v, w, x, y, z)
    !$omp target data map(d) use_device_addr(cptr, cptr_in)
      if (.not. present(u)) stop 10
      if (.not. present(v)) stop 11
      if (.not. present(w)) stop 12
      if (.not. present(x)) stop 13
      if (.not. present(y)) stop 14
      if (.not. present(z)) stop 15
      if (.not. present(cptr)) stop 16
      if (.not. present(cptr_in)) stop 17
      p_u = c_loc(u)
      p_v = c_loc(v)
      p_w = c_loc(w)
      p_x = c_loc(x)
      p_y = c_loc(y)
      p_z = c_loc(z)
      p_cptr = c_loc(cptr)
      p_cptr_in = c_loc(cptr_in)
    !$omp end target data
    !$omp end target data
    call check(p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in, size(x), size(z))
  end subroutine foo

  subroutine check(p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in, Nx, Nz)
    type(c_ptr), value :: p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in
    integer, value :: Nx, Nz
    integer, pointer :: c_u(:), c_v(:), c_w(:), c_x(:), c_y(:), c_z(:)
    type(c_ptr), pointer :: c_cptr(:), c_cptr_in(:)

    ! As is_device_ptr does not handle scalars, we map them to a size-1 array
    call c_f_pointer(p_u, c_u, shape=[1])
    call c_f_pointer(p_v, c_v, shape=[1])
    call c_f_pointer(p_w, c_w, shape=[1])
    call c_f_pointer(p_x, c_x, shape=[Nx])
    call c_f_pointer(p_y, c_y, shape=[1])
    call c_f_pointer(p_z, c_z, shape=[Nz])
    call c_f_pointer(p_cptr, c_cptr, shape=[1])
    call c_f_pointer(p_cptr_in, c_cptr_in, shape=[1])
    call run_target(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz)
  end subroutine check

  subroutine run_target(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz)
    integer, target :: c_u(:), c_v(:), c_w(:), c_x(:), c_y(:), c_z(:)
    type(c_ptr) :: c_cptr(:), c_cptr_in(:)
    integer, value :: Nx, Nz
    !$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)
      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)
    !$omp end target
  end subroutine run_target

  subroutine target_fn(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz)
    !$omp declare target
    integer, target :: c_u, c_v, c_w, c_x(:), c_y, c_z(:)
    type(c_ptr), value :: c_cptr, c_cptr_in
    integer, value :: Nx, Nz
    integer, pointer :: u, x(:)
    if (c_u /= 42) stop 30
    if (c_v /= 5) stop 31
    if (c_w /= 7) stop 32
    if (Nx /= 4) stop 33
    if (any (c_x /= [3,4,6,2])) stop 34
    if (c_y /= 88) stop 35
    if (Nz /= 3) stop 36
    if (any (c_z /= [1,2,3])) stop 37
    if (.not. c_associated (c_cptr)) stop 38
    if (.not. c_associated (c_cptr_in)) stop 39
    if (.not. c_associated (c_cptr, c_loc(c_x))) stop 40
    if (.not. c_associated (c_cptr_in, c_loc(c_u))) stop 41
    call c_f_pointer(c_cptr_in, u)
    call c_f_pointer(c_cptr, x, shape=[Nx])
    if (u /= c_u .or. u /= 42)  stop 42
    if (any (x /= c_x))  stop 43
    if (any (x /= [3,4,6,2]))  stop 44
  end subroutine target_fn
end program main