! { dg-do run } module target_procs use iso_c_binding implicit none (type, external) private public :: copy3_array, copy3_scalar, copy3_array1, copy3_array3 contains subroutine copy3_array_int(from_ptr, to_ptr, N) !$omp declare target real(c_double) :: from_ptr(:) real(c_double) :: to_ptr(:) integer, value :: N integer :: i !$omp parallel do do i = 1, N to_ptr(i) = 3 * from_ptr(i) end do !$omp end parallel do end subroutine copy3_array_int subroutine copy3_scalar_int(from, to) !$omp declare target real(c_double) :: from, to to = 3 * from end subroutine copy3_scalar_int subroutine copy3_array(from, to, N) type(c_ptr), value :: from, to integer, value :: N real(c_double), pointer :: from_ptr(:), to_ptr(:) call c_f_pointer(from, from_ptr, shape=[N]) call c_f_pointer(to, to_ptr, shape=[N]) call do_offload_scalar(from_ptr,to_ptr) contains subroutine do_offload_scalar(from_r, to_r) real(c_double), target :: from_r(:), to_r(:) ! The extra function is needed as is_device_ptr ! requires non-value, non-pointer dummy arguments !$omp target is_device_ptr(from_r, to_r) call copy3_array_int(from_r, to_r, N) !$omp end target end subroutine do_offload_scalar end subroutine copy3_array subroutine copy3_scalar(from, to) type(c_ptr), value, target :: from, to real(c_double), pointer :: from_ptr(:), to_ptr(:) ! Standard-conform detour of using an array as at time of writing ! is_device_ptr below does not handle scalars call c_f_pointer(from, from_ptr, shape=[1]) call c_f_pointer(to, to_ptr, shape=[1]) call do_offload_scalar(from_ptr,to_ptr) contains subroutine do_offload_scalar(from_r, to_r) real(c_double), target :: from_r(:), to_r(:) ! The extra function is needed as is_device_ptr ! requires non-value, non-pointer dummy arguments !$omp target is_device_ptr(from_r, to_r) call copy3_scalar_int(from_r(1), to_r(1)) !$omp end target end subroutine do_offload_scalar end subroutine copy3_scalar subroutine copy3_array1(from, to) real(c_double), target :: from(:), to(:) integer :: N N = size(from) !!$omp target is_device_ptr(from, to) call copy3_array(c_loc(from), c_loc(to), N) !!$omp end target end subroutine copy3_array1 subroutine copy3_array3(from, to) real(c_double), optional, target :: from(:), to(:) integer :: N N = size(from) ! !$omp target is_device_ptr(from, to) call copy3_array(c_loc(from), c_loc(to), N) ! !$omp end target end subroutine copy3_array3 end module target_procs module offloading2 use iso_c_binding use target_procs implicit none (type, external) contains ! Same as main program but uses dummy *nonoptional* arguments subroutine use_device_ptr_sub(AA, BB, CC, DD, EE, FF, AptrA, BptrB, N) real(c_double), pointer :: AA(:), BB(:) real(c_double), allocatable, target :: CC(:), DD(:) real(c_double), target :: EE(N), FF(N), dummy(1) real(c_double), pointer :: AptrA(:), BptrB(:) intent(inout) :: AA, BB, CC, DD, EE, FF integer, value :: N type(c_ptr) :: tgt_aptr, tgt_bptr, tgt_cptr, tgt_dptr, tgt_eptr, tgt_fptr AA = 11.0_c_double BB = 22.0_c_double CC = 33.0_c_double DD = 44.0_c_double EE = 55.0_c_double FF = 66.0_c_double ! pointer-type array to use_device_ptr !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB) call copy3_array(c_loc(AA), c_loc(BB), N) !$omp end target data if (any(abs(AA - 11.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 2 ! allocatable array to use_device_ptr !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD) call copy3_array(c_loc(CC), c_loc(DD), N) !$omp end target data if (any(abs(CC - 33.0_c_double) > 10.0_c_double * epsilon(CC))) stop 3 if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 4 ! fixed-size decriptorless array to use_device_ptr !$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF) call copy3_array(c_loc(EE), c_loc(FF), N) !$omp end target data if (any(abs(EE - 55.0_c_double) > 10.0_c_double * epsilon(EE))) stop 5 if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 6 AA = 111.0_c_double BB = 222.0_c_double CC = 333.0_c_double DD = 444.0_c_double EE = 555.0_c_double FF = 666.0_c_double ! pointer-type array to use_device_ptr !$omp target data map(to:AA) map(from:BB) !$omp target data map(alloc:dummy) use_device_ptr(AA,BB) tgt_aptr = c_loc(AA) tgt_bptr = c_loc(BB) AptrA => AA BptrB => BB !$omp end target data call copy3_array(tgt_aptr, tgt_bptr, N) !$omp target update from(BB) if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 7 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 8 AA = 1111.0_c_double !$omp target update to(AA) call copy3_array(tgt_aptr, tgt_bptr, N) !$omp target update from(BB) if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 9 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 10 ! AprtA tests AA = 7.0_c_double !$omp target update to(AA) call copy3_array(c_loc(AptrA), c_loc(BptrB), N) !$omp target update from(BB) if (any(abs(AA - 7.0_c_double) > 10.0_c_double * epsilon(AA))) stop 11 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 12 AA = 77.0_c_double !$omp target update to(AA) call copy3_array1(AptrA, BptrB) !$omp target update from(BB) if (any(abs(AA - 77.0_c_double) > 10.0_c_double * epsilon(AA))) stop 13 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 14 ! AA = 777.0_c_double ! !$omp target update to(AA) ! call copy3_array2(AptrA, BptrB) ! !$omp target update from(BB) ! if (any(abs(AA - 777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 15 ! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 16 AA = 7777.0_c_double !$omp target update to(AA) call copy3_array3(AptrA, BptrB) !$omp target update from(BB) if (any(abs(AA - 7777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 17 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 18 ! AA = 77777.0_c_double ! !$omp target update to(AA) ! call copy3_array4(AptrA, BptrB) ! !$omp target update from(BB) !$omp end target data ! ! if (any(abs(AA - 77777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 19 ! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 20 ! allocatable array to use_device_ptr !$omp target data map(to:CC) map(from:DD) !$omp target data map(alloc:dummy) use_device_ptr(CC,DD) tgt_cptr = c_loc(CC) tgt_dptr = c_loc(DD) !$omp end target data call copy3_array(tgt_cptr, tgt_dptr, N) !$omp target update from(DD) if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 21 if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 22 CC = 3333.0_c_double !$omp target update to(CC) call copy3_array(tgt_cptr, tgt_dptr, N) !$omp target update from(DD) !$omp end target data if (any(abs(CC - 3333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 23 if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 24 ! fixed-size decriptorless array to use_device_ptr !$omp target data map(to:EE) map(from:FF) !$omp target data map(alloc:dummy) use_device_ptr(EE,FF) tgt_eptr = c_loc(EE) tgt_fptr = c_loc(FF) !$omp end target data call copy3_array(tgt_eptr, tgt_fptr, N) !$omp target update from(FF) if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 25 if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 26 EE = 5555.0_c_double !$omp target update to(EE) call copy3_array(tgt_eptr, tgt_fptr, N) !$omp target update from(FF) !$omp end target data if (any(abs(EE - 5555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 27 if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 28 end subroutine use_device_ptr_sub ! Same as main program but uses dummy *optional* arguments subroutine use_device_ptr_sub2(AA, BB, CC, DD, EE, FF, AptrA, BptrB, N) real(c_double), optional, pointer :: AA(:), BB(:) real(c_double), optional, allocatable, target :: CC(:), DD(:) real(c_double), optional, target :: EE(N), FF(N) real(c_double), pointer :: AptrA(:), BptrB(:) intent(inout) :: AA, BB, CC, DD, EE, FF real(c_double), target :: dummy(1) integer, value :: N type(c_ptr) :: tgt_aptr, tgt_bptr, tgt_cptr, tgt_dptr, tgt_eptr, tgt_fptr AA = 11.0_c_double BB = 22.0_c_double CC = 33.0_c_double DD = 44.0_c_double EE = 55.0_c_double FF = 66.0_c_double ! pointer-type array to use_device_ptr !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB) call copy3_array(c_loc(AA), c_loc(BB), N) !$omp end target data if (any(abs(AA - 11.0_c_double) > 10.0_c_double * epsilon(AA))) stop 29 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 30 ! allocatable array to use_device_ptr !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD) call copy3_array(c_loc(CC), c_loc(DD), N) !$omp end target data if (any(abs(CC - 33.0_c_double) > 10.0_c_double * epsilon(CC))) stop 31 if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 32 ! fixed-size decriptorless array to use_device_ptr !$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF) call copy3_array(c_loc(EE), c_loc(FF), N) !$omp end target data if (any(abs(EE - 55.0_c_double) > 10.0_c_double * epsilon(EE))) stop 33 if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 34 AA = 111.0_c_double BB = 222.0_c_double CC = 333.0_c_double DD = 444.0_c_double EE = 555.0_c_double FF = 666.0_c_double ! pointer-type array to use_device_ptr !$omp target data map(to:AA) map(from:BB) !$omp target data map(alloc:dummy) use_device_ptr(AA,BB) tgt_aptr = c_loc(AA) tgt_bptr = c_loc(BB) AptrA => AA BptrB => BB !$omp end target data call copy3_array(tgt_aptr, tgt_bptr, N) !$omp target update from(BB) if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 35 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 36 AA = 1111.0_c_double !$omp target update to(AA) call copy3_array(tgt_aptr, tgt_bptr, N) !$omp target update from(BB) if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 37 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 38 ! AprtA tests AA = 7.0_c_double !$omp target update to(AA) call copy3_array(c_loc(AptrA), c_loc(BptrB), N) !$omp target update from(BB) if (any(abs(AA - 7.0_c_double) > 10.0_c_double * epsilon(AA))) stop 39 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 40 AA = 77.0_c_double !$omp target update to(AA) call copy3_array1(AptrA, BptrB) !$omp target update from(BB) if (any(abs(AA - 77.0_c_double) > 10.0_c_double * epsilon(AA))) stop 41 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 42 ! AA = 777.0_c_double ! !$omp target update to(AA) ! call copy3_array2(AptrA, BptrB) ! !$omp target update from(BB) ! if (any(abs(AA - 777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 43 ! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 44 AA = 7777.0_c_double !$omp target update to(AA) call copy3_array3(AptrA, BptrB) !$omp target update from(BB) if (any(abs(AA - 7777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 45 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 46 ! AA = 77777.0_c_double ! !$omp target update to(AA) ! call copy3_array4(AptrA, BptrB) ! !$omp target update from(BB) !$omp end target data ! ! if (any(abs(AA - 77777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 47 ! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 48 ! allocatable array to use_device_ptr !$omp target data map(to:CC) map(from:DD) !$omp target data map(alloc:dummy) use_device_ptr(CC,DD) tgt_cptr = c_loc(CC) tgt_dptr = c_loc(DD) !$omp end target data call copy3_array(tgt_cptr, tgt_dptr, N) !$omp target update from(DD) if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 49 if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 50 CC = 3333.0_c_double !$omp target update to(CC) call copy3_array(tgt_cptr, tgt_dptr, N) !$omp target update from(DD) !$omp end target data if (any(abs(CC - 3333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 51 if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 52 ! fixed-size decriptorless array to use_device_ptr !$omp target data map(to:EE) map(from:FF) !$omp target data map(alloc:dummy) use_device_ptr(EE,FF) tgt_eptr = c_loc(EE) tgt_fptr = c_loc(FF) !$omp end target data call copy3_array(tgt_eptr, tgt_fptr, N) !$omp target update from(FF) if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 53 if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 54 EE = 5555.0_c_double !$omp target update to(EE) call copy3_array(tgt_eptr, tgt_fptr, N) !$omp end target data if (any(abs(EE - 5555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 55 if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 56 end subroutine use_device_ptr_sub2 end module offloading2 program omp_device_ptr use iso_c_binding use target_procs use offloading2 implicit none (type, external) integer, parameter :: N = 1000 real(c_double), pointer :: AA(:), BB(:), arg_AA(:), arg_BB(:), arg2_AA(:), arg2_BB(:) real(c_double), allocatable, target :: CC(:), DD(:), arg_CC(:), arg_DD(:), arg2_CC(:), arg2_DD(:) real(c_double), target :: EE(N), FF(N), dummy(1), arg_EE(N), arg_FF(N), arg2_EE(N), arg2_FF(N) real(c_double), pointer :: AptrA(:), BptrB(:) type(c_ptr) :: tgt_aptr, tgt_bptr, tgt_cptr, tgt_dptr, tgt_eptr, tgt_fptr allocate(AA(N), BB(N), CC(N), DD(N)) AA = 11.0_c_double BB = 22.0_c_double CC = 33.0_c_double DD = 44.0_c_double EE = 55.0_c_double FF = 66.0_c_double ! pointer-type array to use_device_ptr !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB) call copy3_array(c_loc(AA), c_loc(BB), N) !$omp end target data if (any(abs(AA - 11.0_c_double) > 10.0_c_double * epsilon(AA))) stop 57 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 58 ! allocatable array to use_device_ptr !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD) call copy3_array(c_loc(CC), c_loc(DD), N) !$omp end target data if (any(abs(CC - 33.0_c_double) > 10.0_c_double * epsilon(CC))) stop 59 if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 60 ! fixed-size decriptorless array to use_device_ptr !$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF) call copy3_array(c_loc(EE), c_loc(FF), N) !$omp end target data if (any(abs(EE - 55.0_c_double) > 10.0_c_double * epsilon(EE))) stop 61 if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 62 AA = 111.0_c_double BB = 222.0_c_double CC = 333.0_c_double DD = 444.0_c_double EE = 555.0_c_double FF = 666.0_c_double ! pointer-type array to use_device_ptr !$omp target data map(to:AA) map(from:BB) !$omp target data map(alloc:dummy) use_device_ptr(AA,BB) tgt_aptr = c_loc(AA) tgt_bptr = c_loc(BB) AptrA => AA BptrB => BB !$omp end target data call copy3_array(tgt_aptr, tgt_bptr, N) !$omp target update from(BB) if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 63 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 64 AA = 1111.0_c_double !$omp target update to(AA) call copy3_array(tgt_aptr, tgt_bptr, N) !$omp target update from(BB) if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 65 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 66 ! AprtA tests AA = 7.0_c_double !$omp target update to(AA) call copy3_array(c_loc(AptrA), c_loc(BptrB), N) !$omp target update from(BB) if (any(abs(AA - 7.0_c_double) > 10.0_c_double * epsilon(AA))) stop 67 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 68 AA = 77.0_c_double !$omp target update to(AA) call copy3_array1(AptrA, BptrB) !$omp target update from(BB) if (any(abs(AA - 77.0_c_double) > 10.0_c_double * epsilon(AA))) stop 69 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 70 ! AA = 777.0_c_double ! !$omp target update to(AA) ! call copy3_array2(AptrA, BptrB) ! !$omp target update from(BB) ! if (any(abs(AA - 777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 71 ! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 72 AA = 7777.0_c_double !$omp target update to(AA) call copy3_array3(AptrA, BptrB) !$omp target update from(BB) if (any(abs(AA - 7777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 73 if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 74 ! AA = 77777.0_c_double ! !$omp target update to(AA) ! call copy3_array4(AptrA, BptrB) ! !$omp target update from(BB) !$omp end target data ! ! if (any(abs(AA - 77777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 75 ! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 76 ! allocatable array to use_device_ptr !$omp target data map(to:CC) map(from:DD) !$omp target data map(alloc:dummy) use_device_ptr(CC,DD) tgt_cptr = c_loc(CC) tgt_dptr = c_loc(DD) !$omp end target data call copy3_array(tgt_cptr, tgt_dptr, N) !$omp target update from(DD) if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 77 if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 78 CC = 3333.0_c_double !$omp target update to(CC) call copy3_array(tgt_cptr, tgt_dptr, N) !$omp target update from(DD) !$omp end target data if (any(abs(CC - 3333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 79 if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 80 ! fixed-size decriptorless array to use_device_ptr !$omp target data map(to:EE) map(from:FF) !$omp target data map(alloc:dummy) use_device_ptr(EE,FF) tgt_eptr = c_loc(EE) tgt_fptr = c_loc(FF) !$omp end target data call copy3_array(tgt_eptr, tgt_fptr, N) !$omp target update from(FF) if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 81 if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 82 EE = 5555.0_c_double !$omp target update to(EE) call copy3_array(tgt_eptr, tgt_fptr, N) !$omp target update from(FF) !$omp end target data if (any(abs(EE - 5555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 83 if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 84 deallocate(AA, BB) ! Free pointers only AptrA => null() BptrB => null() allocate(arg_AA(N), arg_BB(N), arg_CC(N), arg_DD(N)) call use_device_ptr_sub(arg_AA, arg_BB, arg_CC, arg_DD, arg_EE, arg_FF, AptrA, BptrB, N) deallocate(arg_AA, arg_BB) AptrA => null() BptrB => null() allocate(arg2_AA(N), arg2_BB(N), arg2_CC(N), arg2_DD(N)) call use_device_ptr_sub2(arg2_AA, arg2_BB, arg2_CC, arg2_DD, arg2_EE, arg2_FF, AptrA, BptrB, N) deallocate(arg2_AA, arg2_BB) end program omp_device_ptr