* [patch][OpenMP,Fortran] Fix trans-openmp.c, add use_device_addr run-time test case (has known issues with actual offloading)
@ 2019-10-04 13:54 Tobias Burnus
2019-10-07 23:12 ` [patch][OpenMP,Fortran] Fix several OpenMP use_device_addr/map/update errors found by a length test case Tobias Burnus
0 siblings, 1 reply; 6+ messages in thread
From: Tobias Burnus @ 2019-10-04 13:54 UTC (permalink / raw)
To: gcc-patches, fortran, Jakub Jelinek
[-- Attachment #1: Type: text/plain, Size: 971 bytes --]
This use_device_addr patch does:
* Add trivial but crucial missing change to "fortran/trans-openmp.c (Ups!)
* Add a comprehensive set of test cases (only scalars and
non-array-descriptor arrays)
Remarks:
* The test cases are known to mishandle "cc/dd/ee/ff" (= scalars with
allocatable + pointer attribute). That's only visible with actual
offloading as with shared memory the errors cancel and it works.
* OpenMP spec: As the test case shows, "is_device_ptr" with
"type(c_ptr), VALUE" would be nice; but OpenMP's spec for is_device_ptr
only permits dummy arguments without VALUE attribute.
* Known shortcomings (omp-low.c implementation; not tested for): arrays
with descriptor (alloctable/pointer arrays), absent optional variables,
polymorphic variables. [For the first two, draft patches exist.]
Comments, esp. to the test case?
Tobias
PS: My next planned task is to fix the "scalars with allocatable +
pointer attribute" issue revealed in this case.
[-- Attachment #2: use_device_addr_fix-testcase.diff --]
[-- Type: text/x-patch, Size: 47018 bytes --]
gcc/fortran/
* trans-openmp.c (gfc_trans_omp_clauses): Handle
OMP_LIST_USE_DEVICE_ADDR.
libgomp/
* testsuite/libgomp.fortran/use_device_addr-1.f90: New.
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index f83bab4850e..35c2f280fb6 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -1887,6 +1887,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
case OMP_LIST_USE_DEVICE_PTR:
clause_code = OMP_CLAUSE_USE_DEVICE_PTR;
goto add_clause;
+ case OMP_LIST_USE_DEVICE_ADDR:
+ clause_code = OMP_CLAUSE_USE_DEVICE_ADDR;
+ goto add_clause;
case OMP_LIST_IS_DEVICE_PTR:
clause_code = OMP_CLAUSE_IS_DEVICE_PTR;
goto add_clause;
diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90
new file mode 100644
index 00000000000..7a45c989ad5
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90
@@ -0,0 +1,1196 @@
+! Comprehensive run-time test for use_device_addr
+!
+! Untested:
+! - arrays with array descriptor
+! - polymorphic variables
+! - absent optional arguments
+!
+module target_procs
+ use iso_c_binding
+ implicit none
+ private
+ public :: copy3_array, copy3_scalar
+contains
+ subroutine copy3_array_int(from_intptr, to_intptr, N)
+ !$omp declare target
+ !type(c_ptr), value :: from, to
+ integer(c_intptr_t), value :: from_intptr, to_intptr ! VALUE issue, cf. copy3_array
+ type(c_ptr) :: from, to
+ integer, value :: N
+
+ real(c_double), pointer :: from_ptr(:)
+ real(c_double), pointer :: to_ptr(:)
+ integer :: i
+
+ from = transfer(from_intptr, mold=from)
+ to = transfer(to_intptr, mold=to)
+ call c_f_pointer(from, from_ptr, shape=[N])
+ call c_f_pointer(to, to_ptr, shape=[N])
+
+ !$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_intptr, to_intptr)
+ !$omp declare target
+ !type(c_ptr), value :: from, to
+ integer(c_intptr_t), value :: from_intptr, to_intptr ! VALUE issue, cf. copy3_array
+ type(c_ptr) :: from, to
+
+ real(c_double), pointer :: from_ptr
+ real(c_double), pointer :: to_ptr
+
+ from = transfer(from_intptr, mold=from)
+ to = transfer(to_intptr, mold=to)
+ call c_f_pointer(from, from_ptr)
+ call c_f_pointer(to, to_ptr)
+
+ to_ptr = 3 * from_ptr
+ end subroutine copy3_scalar_int
+
+
+ subroutine copy3_array(from, to, N)
+ type(c_ptr) :: from, to
+ integer, value :: N
+! [OpenMP issue:] Would like to use the following but it is not permitted due to VALUE.
+! !$omp target is_device_ptr(from, to)
+! call copy3_array_int(from, to, N)
+! !$omp end target
+! Hence:
+ integer(c_intptr_t) :: from_intptr, to_intptr
+
+ from_intptr = transfer(from, mold=from_intptr)
+ to_intptr = transfer(to, mold=to_intptr)
+
+ !$omp target
+ call copy3_array_int(from_intptr, to_intptr, N)
+ !$omp end target
+ end subroutine copy3_array
+
+ subroutine copy3_scalar(from, to)
+ type(c_ptr), value :: from, to ! VALUE issue, cf. copy3_array above
+ integer(c_intptr_t) :: from_intptr, to_intptr
+
+ from_intptr = transfer(from, mold=from_intptr)
+ to_intptr = transfer(to, mold=to_intptr)
+
+ !$omp target
+ call copy3_scalar_int(from_intptr, to_intptr)
+ !$omp end target
+ end subroutine copy3_scalar
+end module target_procs
+
+
+
+! Test local dummy arguments (w/o optional)
+module test_dummies
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_call_1, test_dummy_call_2
+contains
+ subroutine test_dummy_call_1()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ allocate(cc, dd, ee, ff)
+
+ 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
+ gg = 77.0_c_double
+ hh = 88.0_c_double
+
+ call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_dummy_call_1
+
+ subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+ integer, value :: N
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ call copy3_scalar(c_loc(cc), c_loc(dd))
+ !$omp end target data
+ if (abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ call copy3_scalar(c_loc(ee), c_loc(ff))
+ !$omp end target data
+ if (abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
+ call copy3_array(c_loc(gg), c_loc(hh), N)
+ !$omp end target data
+ if (any(abs(gg - 77.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ end subroutine test_dummy_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_call_2()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_double), pointer :: gptr(:), hptr(:)
+
+ allocate(cc, dd, ee, ff)
+ call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ deallocate(ee, ff)
+ end subroutine test_dummy_call_2
+
+ subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_double), pointer :: gptr(:), hptr(:)
+
+ integer, value :: N
+
+ real(c_double) :: dummy
+
+ 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
+ gg = 777.0_c_double
+ hh = 888.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+
+ !$omp target data map(to:cc) map(from:dd)
+ !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
+ c_cptr = c_loc(cc)
+ c_dptr = c_loc(dd)
+ cptr => cc
+ dptr => dd
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_loc(cptr), c_loc(dptr))
+ !$omp target update from(dd)
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+ !$omp end target data
+
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) call abort()
+
+
+ !$omp target data map(to:ee) map(from:ff)
+ !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_loc(eptr), c_loc(fptr))
+ !$omp target update from(ff)
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) call abort()
+ !$omp end target data
+
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh)
+ !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
+ c_gptr = c_loc(gg)
+ c_hptr = c_loc(hh)
+ gptr => gg
+ hptr => hh
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ gg = 7777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 7777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+
+ ! check Fortran pointer after target-value modification
+ gg = 77777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_loc(gptr), c_loc(hptr), N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ !$omp end target data
+
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ end subroutine test_dummy_callee_2
+end module test_dummies
+
+
+
+! Test local dummy arguments + VALUE (w/o optional)
+module test_dummies_value
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_val_call_1, test_dummy_val_call_2
+contains
+ subroutine test_dummy_val_call_1()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_double), target :: aa, bb
+
+ aa = 11.0_c_double
+ bb = 22.0_c_double
+
+ call test_dummy_val_callee_1(aa, bb)
+ end subroutine test_dummy_val_call_1
+
+ subroutine test_dummy_val_callee_1(aa, bb)
+ ! scalars
+ real(c_double), value, target :: aa, bb
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ end subroutine test_dummy_val_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_val_call_2()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_double), target :: aa, bb
+ type(c_ptr) :: c_aptr, c_bptr
+ real(c_double), pointer :: aptr, bptr
+
+ call test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ end subroutine test_dummy_val_call_2
+
+ subroutine test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ real(c_double), value, target :: aa, bb
+ type(c_ptr), value :: c_aptr, c_bptr
+ real(c_double), pointer :: aptr, bptr
+
+ real(c_double) :: dummy
+
+ aa = 111.0_c_double
+ bb = 222.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ end subroutine test_dummy_val_callee_2
+end module test_dummies_value
+
+
+
+! Test local dummy arguments + OPTIONAL
+! Values present and ptr associated to nonzero
+module test_dummies_opt
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_opt_call_1, test_dummy_opt_call_2
+contains
+ subroutine test_dummy_opt_call_1()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ allocate(cc, dd, ee, ff)
+
+ 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
+ gg = 77.0_c_double
+ hh = 88.0_c_double
+
+ call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_dummy_opt_call_1
+
+ subroutine test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ ! scalars
+ real(c_double), optional, target :: aa, bb
+ real(c_double), optional, target, allocatable :: cc, dd
+ real(c_double), optional, pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), optional, target :: gg(N), hh(N)
+ integer, value :: N
+
+ ! All shall be present - and pointing to non-NULL
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
+ call copy3_scalar(c_loc(cc), c_loc(dd))
+ !$omp end target data
+ if (abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
+ call copy3_scalar(c_loc(ee), c_loc(ff))
+ !$omp end target data
+ if (abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+ if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
+ call copy3_array(c_loc(gg), c_loc(hh), N)
+ !$omp end target data
+ if (any(abs(gg - 77.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ end subroutine test_dummy_opt_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_opt_call_2()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_double), pointer :: gptr(:), hptr(:)
+
+ allocate(cc, dd, ee, ff)
+ call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ deallocate(ee, ff)
+ end subroutine test_dummy_opt_call_2
+
+ subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ ! scalars
+ real(c_double), optional, target :: aa, bb
+ real(c_double), optional, target, allocatable :: cc, dd
+ real(c_double), optional, pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), optional, target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_double), optional, pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_double), optional, pointer :: gptr(:), hptr(:)
+
+ integer, value :: N
+
+ real(c_double) :: dummy
+
+ ! All shall be present - and pointing to non-NULL
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+
+ 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
+ gg = 777.0_c_double
+ hh = 888.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
+ if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
+ !$omp end target data
+
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
+ if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+
+ !$omp target data map(to:cc) map(from:dd)
+ !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
+ c_cptr = c_loc(cc)
+ c_dptr = c_loc(dd)
+ cptr => cc
+ dptr => dd
+ if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) call abort()
+ if (.not.associated(cptr) .or. .not.associated(dptr)) call abort()
+ !$omp end target data
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
+ if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) call abort()
+ if (.not.associated(cptr) .or. .not.associated(dptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_loc(cptr), c_loc(dptr))
+ !$omp target update from(dd)
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+ !$omp end target data
+
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) call abort()
+
+
+ !$omp target data map(to:ee) map(from:ff)
+ !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) call abort()
+ if (.not.associated(eptr) .or. .not.associated(fptr)) call abort()
+ !$omp end target data
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
+ if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) call abort()
+ if (.not.associated(eptr) .or. .not.associated(fptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_loc(eptr), c_loc(fptr))
+ !$omp target update from(ff)
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) call abort()
+ !$omp end target data
+
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh)
+ !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+ if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
+ c_gptr = c_loc(gg)
+ c_hptr = c_loc(hh)
+ gptr => gg
+ hptr => hh
+ if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) call abort()
+ if (.not.associated(gptr) .or. .not.associated(hptr)) call abort()
+ !$omp end target data
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+ if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
+ if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) call abort()
+ if (.not.associated(gptr) .or. .not.associated(hptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ gg = 7777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 7777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+
+ ! check Fortran pointer after target-value modification
+ gg = 77777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_loc(gptr), c_loc(hptr), N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ !$omp end target data
+
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ end subroutine test_dummy_opt_callee_2
+end module test_dummies_opt
+
+
+
+! Test local dummy arguments + OPTIONAL + VALUE
+! Values present
+module test_dummies_opt_value
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_opt_val_call_1, test_dummy_opt_val_call_2
+contains
+ subroutine test_dummy_opt_val_call_1()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_double), target :: aa, bb
+
+ aa = 11.0_c_double
+ bb = 22.0_c_double
+
+ call test_dummy_opt_val_callee_1(aa, bb)
+ end subroutine test_dummy_opt_val_call_1
+
+ subroutine test_dummy_opt_val_callee_1(aa, bb)
+ ! scalars
+ real(c_double), optional, value, target :: aa, bb
+
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ end subroutine test_dummy_opt_val_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_opt_val_call_2()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_double), target :: aa, bb
+ type(c_ptr) :: c_aptr, c_bptr
+ real(c_double), pointer :: aptr, bptr
+
+ call test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ end subroutine test_dummy_opt_val_call_2
+
+ subroutine test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ real(c_double), optional, value, target :: aa, bb
+ type(c_ptr), optional, value :: c_aptr, c_bptr
+ real(c_double), optional, pointer :: aptr, bptr
+
+ real(c_double) :: dummy
+
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
+ if (.not.present(aptr) .or. .not.present(bptr)) call abort()
+
+ aa = 111.0_c_double
+ bb = 222.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
+ if (.not.present(aptr) .or. .not.present(bptr)) call abort()
+
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
+ if (.not.present(aptr) .or. .not.present(bptr)) call abort()
+
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
+ if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ end subroutine test_dummy_opt_val_callee_2
+end module test_dummies_opt_value
+
+
+
+! Test nullptr
+module test_nullptr
+ use iso_c_binding
+ implicit none
+ private
+ public :: test_nullptr_1
+contains
+ subroutine test_nullptr_1()
+ ! scalars
+ real(c_double), pointer :: aa, bb
+ real(c_double), pointer :: ee, ff
+
+ type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr
+ real(c_double), pointer :: aptr, bptr, eptr, fptr
+
+ aa => null()
+ bb => null()
+ ee => null()
+ ff => null()
+
+ if (associated(aa) .or. associated(bb)) call abort()
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (c_associated(c_loc(aa)) .or. c_associated(c_loc(bb))) call abort()
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ if (c_associated(c_aptr) .or. c_associated(c_bptr)) call abort()
+ if (associated(aptr) .or. associated(bptr, bb)) call abort()
+ !$omp end target data
+ if (c_associated(c_aptr) .or. c_associated(c_bptr)) call abort()
+ if (associated(aptr) .or. associated(bptr, bb)) call abort()
+
+ call test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
+ end subroutine test_nullptr_1
+
+ subroutine test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
+ ! scalars
+ real(c_double), optional, pointer :: ee, ff
+
+ type(c_ptr), optional :: c_eptr, c_fptr
+ real(c_double), optional, pointer :: eptr, fptr
+
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (associated(ee) .or. associated(ff)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (associated(ee) .or. associated(ff)) call abort()
+ if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) call abort()
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ if (c_associated(c_eptr) .or. c_associated(c_fptr)) call abort()
+ if (associated(eptr) .or. associated(fptr)) call abort()
+ !$omp end target data
+
+ if (c_associated(c_eptr) .or. c_associated(c_fptr)) call abort()
+ if (associated(eptr) .or. associated(fptr)) call abort()
+ end subroutine test_dummy_opt_nullptr_callee_1
+end module test_nullptr
+
+
+
+! Test local variables
+module tests
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_main_1, test_main_2
+contains
+ ! map + use_device_addr + c_loc
+ subroutine test_main_1()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ allocate(cc, dd, ee, ff)
+
+
+ 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
+ gg = 77.0_c_double
+ hh = 88.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ call copy3_scalar(c_loc(cc), c_loc(dd))
+ !$omp end target data
+ if (abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ call copy3_scalar(c_loc(ee), c_loc(ff))
+ !$omp end target data
+ if (abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
+ call copy3_array(c_loc(gg), c_loc(hh), N)
+ !$omp end target data
+ if (any(abs(gg - 77.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_main_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_main_2
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ real(c_double) :: dummy
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_double), pointer :: gptr(:), hptr(:)
+
+ allocate(cc, dd, ee, ff)
+
+ 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
+ gg = 777.0_c_double
+ hh = 888.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+
+ !$omp target data map(to:cc) map(from:dd)
+ !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
+ c_cptr = c_loc(cc)
+ c_dptr = c_loc(dd)
+ cptr => cc
+ dptr => dd
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_loc(cptr), c_loc(dptr))
+ !$omp target update from(dd)
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+ !$omp end target data
+
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) call abort()
+
+
+ !$omp target data map(to:ee) map(from:ff)
+ !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_loc(eptr), c_loc(fptr))
+ !$omp target update from(ff)
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) call abort()
+ !$omp end target data
+
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh)
+ !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
+ c_gptr = c_loc(gg)
+ c_hptr = c_loc(hh)
+ gptr => gg
+ hptr => hh
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ gg = 7777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 7777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+
+ ! check Fortran pointer after target-value modification
+ gg = 77777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_loc(gptr), c_loc(hptr), N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ !$omp end target data
+
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+
+ deallocate(ee, ff)
+ end subroutine test_main_2
+end module tests
+
+
+program omp_device_addr
+ use tests
+ use test_dummies
+ use test_dummies_value
+ use test_dummies_opt
+ use test_dummies_opt_value
+ use test_nullptr
+ implicit none
+
+ call test_main_1()
+ call test_main_2()
+
+ call test_dummy_call_1()
+ call test_dummy_call_2()
+
+ call test_dummy_val_call_1()
+ call test_dummy_val_call_2()
+
+ call test_dummy_opt_call_1()
+ call test_dummy_opt_call_2()
+
+ call test_dummy_opt_val_call_1()
+ call test_dummy_opt_val_call_2()
+
+ call test_nullptr_1()
+end program omp_device_addr
^ permalink raw reply [flat|nested] 6+ messages in thread
* [patch][OpenMP,Fortran] Fix several OpenMP use_device_addr/map/update errors found by a length test case
2019-10-04 13:54 [patch][OpenMP,Fortran] Fix trans-openmp.c, add use_device_addr run-time test case (has known issues with actual offloading) Tobias Burnus
@ 2019-10-07 23:12 ` Tobias Burnus
2019-10-10 12:22 ` Jakub Jelinek
0 siblings, 1 reply; 6+ messages in thread
From: Tobias Burnus @ 2019-10-07 23:12 UTC (permalink / raw)
To: gcc-patches, fortran, Jakub Jelinek
[-- Attachment #1: Type: text/plain, Size: 1253 bytes --]
This patch includes a rather comprehensive test case for
"use_device_addr" – and fixes the fall out. Notes:
* Only scalars and non-descriptor arrays are tested
* In particular, polymorphic types, absent optional arguments and
array-descriptor arrays are not; nor are associate-block variables nor
cray pointees.
* "use_device_ptr" has not been tested (beyond what's currently in the
test suite)
* Assumption (based on the OpenMP spec): within a "omp target data …
use_device_addr(var)" block, c_loc is used to access the address and it
is the only pointer which will end up on the device – everything else
("meta data") is only host data (i.e. present status, dynamic type,
array shape).
* OpenMP spec: is_device_ptr with "type(c), value" would be nice (cf.
test-case file; but OpenMP 5 currently only permits dummy arguments w/o
value/allocatable/pointer attribute).
This patch fixes:
* An issue with MAP and VALUE
* An issue with UPDATE target and pointer/allocatable scalars
* use_device_addr: Actually pass clause to the ME and fix several issues
there, mostly related to optional and pointer/allocatable.
Tested with nvptx – and bootstrapped w/ and without offloading support.
OK for the trunk?
Tobias
[-- Attachment #2: use_device_addr-alloc-ptr-v6.diff --]
[-- Type: text/x-patch, Size: 106475 bytes --]
gcc/fortran/
* f95-lang.c (LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR): Re-define to
gfc_omp_is_allocatable_or_ptr.
* trans-decl.c (create_function_arglist): Set GFC_DECL_OPTIONAL_ARGUMENT
only if not passed by value.
* trans-openmp.c (gfc_omp_is_allocatable_or_ptr): New.
(gfc_trans_omp_clauses): Actually pass use_device_addr on to the middle
end; for MAP, handle (present) optional arguments; for target update,
handle allocatable/pointer scalars.
* trans.h (gfc_omp_is_allocatable_or_ptr): Declare.
gcc/
* langhooks-def.h (LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR): Define.
(LANG_HOOKS_DECLS): Add it.
* langhooks.h (lang_hooks_for_decls): Add omp_is_allocatable_or_ptr;
update comment for omp_is_optional_argument.
* omp-general.c (omp_is_allocatable_or_ptr): New.
* omp-general.h (omp_is_allocatable_or_ptr): Declare.
* omp-low.c (scan_sharing_clauses, lower_omp_target): Handle
Fortran's optional arguments and allocatable/pointer scalars
with use_device_addr.
libgomp/
* testsuite/libgomp.fortran/use_device_addr-1.f90: New.
* testsuite/libgomp.fortran/use_device_addr-2.f90: New.
gcc/fortran/f95-lang.c | 2 +
gcc/fortran/trans-decl.c | 3 +-
gcc/fortran/trans-openmp.c | 35 +-
gcc/fortran/trans.h | 1 +
gcc/langhooks-def.h | 2 +
gcc/langhooks.h | 9 +-
gcc/omp-general.c | 8 +
gcc/omp-general.h | 1 +
gcc/omp-low.c | 38 +-
.../libgomp.fortran/use_device_addr-1.f90 | 1202 ++++++++++++++++++++
.../libgomp.fortran/use_device_addr-2.f90 | 1202 ++++++++++++++++++++
11 files changed, 2489 insertions(+), 14 deletions(-)
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c
index 2467cd968af..0f72ab9e3b4 100644
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -113,6 +113,7 @@ static const struct attribute_spec gfc_attribute_table[] =
#undef LANG_HOOKS_TYPE_FOR_MODE
#undef LANG_HOOKS_TYPE_FOR_SIZE
#undef LANG_HOOKS_INIT_TS
+#undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR
#undef LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT
#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
#undef LANG_HOOKS_OMP_PREDETERMINED_SHARING
@@ -146,6 +147,7 @@ static const struct attribute_spec gfc_attribute_table[] =
#define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode
#define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size
#define LANG_HOOKS_INIT_TS gfc_init_ts
+#define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR gfc_omp_is_allocatable_or_ptr
#define LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT gfc_omp_is_optional_argument
#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference
#define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index b701f493440..698d90a4d42 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2691,8 +2691,9 @@ create_function_arglist (gfc_symbol * sym)
&& (!f->sym->attr.proc_pointer
&& f->sym->attr.flavor != FL_PROCEDURE))
DECL_BY_REFERENCE (parm) = 1;
- if (f->sym->attr.optional)
+ if (f->sym->attr.optional && !f->sym->attr.value)
{
+ // With value, the argument is passed as is
gfc_allocate_lang_decl (parm);
GFC_DECL_OPTIONAL_ARGUMENT (parm) = 1;
}
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index f83bab4850e..dad11a24430 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -47,7 +47,21 @@ along with GCC; see the file COPYING3. If not see
int ompws_flags;
-/* True if OpenMP should treat this DECL as an optional argument. */
+/* True if OpenMP should regard this DECL as being a scalar which has Fortran's
+ allocatable or pointer attribute. */
+
+bool
+gfc_omp_is_allocatable_or_ptr (const_tree decl)
+{
+ return (DECL_P (decl)
+ && (GFC_DECL_GET_SCALAR_POINTER (decl)
+ || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)));
+}
+
+/* True if OpenMP should treat this DECL as an optional argument; note: for
+ arguments with VALUE attribute, the DECL is identical to nonoptional
+ arguments; hence, we return false here. To check whether the variable is
+ present, use the DECL which is passed as hidden argument. */
bool
gfc_omp_is_optional_argument (const_tree decl)
@@ -1887,6 +1901,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
case OMP_LIST_USE_DEVICE_PTR:
clause_code = OMP_CLAUSE_USE_DEVICE_PTR;
goto add_clause;
+ case OMP_LIST_USE_DEVICE_ADDR:
+ clause_code = OMP_CLAUSE_USE_DEVICE_ADDR;
+ goto add_clause;
case OMP_LIST_IS_DEVICE_PTR:
clause_code = OMP_CLAUSE_IS_DEVICE_PTR;
goto add_clause;
@@ -2170,7 +2187,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_DECL (node4) = decl;
OMP_CLAUSE_SIZE (node4) = size_int (0);
decl = build_fold_indirect_ref (decl);
- if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
+ if ((TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
+ || gfc_omp_is_optional_argument (orig_decl))
&& (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
{
@@ -2414,7 +2432,11 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
{
tree decl = gfc_trans_omp_variable (n->sym, false);
if (gfc_omp_privatize_by_reference (decl))
- decl = build_fold_indirect_ref (decl);
+ {
+ if (gfc_omp_is_allocatable_or_ptr (decl))
+ decl = build_fold_indirect_ref (decl);
+ decl = build_fold_indirect_ref (decl);
+ }
else if (DECL_P (decl))
TREE_ADDRESSABLE (decl) = 1;
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
@@ -2436,7 +2458,12 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node), elemsz);
}
else
- OMP_CLAUSE_DECL (node) = decl;
+ {
+ OMP_CLAUSE_DECL (node) = decl;
+ if (gfc_omp_is_allocatable_or_ptr (decl))
+ OMP_CLAUSE_SIZE (node)
+ = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (decl)));
+ }
}
else
{
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 405e88dd1c4..e96b22acc68 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -786,6 +786,7 @@ struct array_descr_info;
bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
/* In trans-openmp.c */
+bool gfc_omp_is_allocatable_or_ptr (const_tree);
bool gfc_omp_is_optional_argument (const_tree);
bool gfc_omp_privatize_by_reference (const_tree);
enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree);
diff --git a/gcc/langhooks-def.h b/gcc/langhooks-def.h
index 55d5fe01495..c5dc83d1cc8 100644
--- a/gcc/langhooks-def.h
+++ b/gcc/langhooks-def.h
@@ -236,6 +236,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree);
#define LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL lhd_warn_unused_global_decl
#define LANG_HOOKS_POST_COMPILATION_PARSING_CLEANUPS NULL
#define LANG_HOOKS_DECL_OK_FOR_SIBCALL lhd_decl_ok_for_sibcall
+#define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR hook_bool_const_tree_false
#define LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT hook_bool_const_tree_false
#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE hook_bool_const_tree_false
#define LANG_HOOKS_OMP_PREDETERMINED_SHARING lhd_omp_predetermined_sharing
@@ -262,6 +263,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree);
LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL, \
LANG_HOOKS_POST_COMPILATION_PARSING_CLEANUPS, \
LANG_HOOKS_DECL_OK_FOR_SIBCALL, \
+ LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR, \
LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT, \
LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE, \
LANG_HOOKS_OMP_PREDETERMINED_SHARING, \
diff --git a/gcc/langhooks.h b/gcc/langhooks.h
index 9d2714a5b1d..97e3186a41d 100644
--- a/gcc/langhooks.h
+++ b/gcc/langhooks.h
@@ -222,7 +222,14 @@ struct lang_hooks_for_decls
/* True if this decl may be called via a sibcall. */
bool (*ok_for_sibcall) (const_tree);
- /* True if OpenMP should treat DECL as a Fortran optional argument. */
+ /* True if OpenMP should regard this DECL as being a scalar which has Fortran's
+ allocatable or pointer attribute. */
+ bool (*omp_is_allocatable_or_ptr) (const_tree);
+
+ /* True if OpenMP should treat DECL as a Fortran optional argument; note: for
+ arguments with VALUE attribute, the DECL is identical to nonoptional
+ arguments; hence, we return false here. To check whether the variable is
+ present, use the DECL which is passed as hidden argument. */
bool (*omp_is_optional_argument) (const_tree);
/* True if OpenMP should privatize what this DECL points to rather
diff --git a/gcc/omp-general.c b/gcc/omp-general.c
index 5ef6e251698..1a78a70bd57 100644
--- a/gcc/omp-general.c
+++ b/gcc/omp-general.c
@@ -48,6 +48,14 @@ omp_find_clause (tree clauses, enum omp_clause_code kind)
return NULL_TREE;
}
+/* True if OpenMP should regard this DECL as being a scalar which has Fortran's
+ allocatable or pointer attribute. */
+bool
+omp_is_allocatable_or_ptr (tree decl)
+{
+ return lang_hooks.decls.omp_is_allocatable_or_ptr (decl);
+}
+
/* Return true if DECL is a Fortran optional argument. */
bool
diff --git a/gcc/omp-general.h b/gcc/omp-general.h
index bbaa7b11707..7cd1d216fc0 100644
--- a/gcc/omp-general.h
+++ b/gcc/omp-general.h
@@ -73,6 +73,7 @@ struct omp_for_data
#define OACC_FN_ATTRIB "oacc function"
extern tree omp_find_clause (tree clauses, enum omp_clause_code kind);
+extern bool omp_is_allocatable_or_ptr (tree decl);
extern bool omp_is_optional_argument (tree decl);
extern bool omp_is_reference (tree decl);
extern void omp_adjust_for_condition (location_t loc, enum tree_code *cond_code,
diff --git a/gcc/omp-low.c b/gcc/omp-low.c
index ca7dfdb83a1..a635d736154 100644
--- a/gcc/omp-low.c
+++ b/gcc/omp-low.c
@@ -1241,7 +1241,8 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
case OMP_CLAUSE_USE_DEVICE_ADDR:
decl = OMP_CLAUSE_DECL (c);
if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
- && !omp_is_reference (decl))
+ && !omp_is_reference (decl)
+ && !omp_is_allocatable_or_ptr (decl))
|| TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
install_var_field (decl, true, 11, ctx);
else
@@ -11483,7 +11484,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
DECL_HAS_VALUE_EXPR_P (new_var) = 1;
}
else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
- && !omp_is_reference (var))
+ && !omp_is_reference (var)
+ && !omp_is_allocatable_or_ptr (var))
|| TREE_CODE (TREE_TYPE (var)) == ARRAY_TYPE)
{
tree new_var = lookup_decl (var, ctx);
@@ -11678,7 +11680,18 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
}
else
{
- var = build_fold_addr_expr (var);
+ // While MAP is handled explicitly by the FE,
+ // for 'target update', only the identified is passed.
+ if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_FROM
+ || OMP_CLAUSE_CODE (c) == OMP_CLAUSE_TO)
+ && (omp_is_allocatable_or_ptr (var)
+ && omp_is_optional_argument (var)))
+ var = build_fold_indirect_ref (var);
+ else if ((OMP_CLAUSE_CODE (c) != OMP_CLAUSE_FROM
+ && OMP_CLAUSE_CODE (c) != OMP_CLAUSE_TO)
+ || (!omp_is_allocatable_or_ptr (var)
+ && !omp_is_optional_argument (var)))
+ var = build_fold_addr_expr (var);
gimplify_assign (x, var, &ilist);
}
}
@@ -11865,16 +11878,22 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
}
type = TREE_TYPE (ovar);
if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
- && !omp_is_reference (ovar))
+ && !omp_is_reference (ovar)
+ && !omp_is_allocatable_or_ptr (ovar))
|| TREE_CODE (type) == ARRAY_TYPE)
var = build_fold_addr_expr (var);
else
{
- if (omp_is_reference (ovar) || omp_is_optional_argument (ovar))
+ if (omp_is_reference (ovar)
+ || omp_is_optional_argument (ovar)
+ || omp_is_allocatable_or_ptr (ovar))
{
type = TREE_TYPE (type);
if (TREE_CODE (type) != ARRAY_TYPE
- && OMP_CLAUSE_CODE (c) != OMP_CLAUSE_USE_DEVICE_ADDR)
+ && ((OMP_CLAUSE_CODE (c) != OMP_CLAUSE_USE_DEVICE_ADDR
+ && !omp_is_allocatable_or_ptr (ovar))
+ || (omp_is_reference (ovar)
+ && omp_is_allocatable_or_ptr (ovar))))
var = build_simple_mem_ref (var);
var = fold_convert (TREE_TYPE (x), var);
}
@@ -12045,7 +12064,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
gimple_build_assign (new_var, x));
}
else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
- && !omp_is_reference (var))
+ && !omp_is_reference (var)
+ && !omp_is_allocatable_or_ptr (var))
|| TREE_CODE (TREE_TYPE (var)) == ARRAY_TYPE)
{
tree new_var = lookup_decl (var, ctx);
@@ -12065,7 +12085,9 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
{
type = TREE_TYPE (type);
if (TREE_CODE (type) != ARRAY_TYPE
- && OMP_CLAUSE_CODE (c) != OMP_CLAUSE_USE_DEVICE_ADDR)
+ && (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_USE_DEVICE_ADDR
+ || (omp_is_reference (var)
+ && omp_is_allocatable_or_ptr (var))))
{
tree v = create_tmp_var_raw (type, get_name (var));
gimple_add_tmp_var (v);
diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90
new file mode 100644
index 00000000000..852fad6d2f5
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90
@@ -0,0 +1,1202 @@
+! Comprehensive run-time test for use_device_addr
+!
+! Differs from use_device_addr-2.f90 by using a 8-byte variable (c_double)
+!
+! This test case assumes that a 'var' appearing in 'use_device_addr' is
+! only used as 'c_loc(var)' - such that only the actual data is used/usable
+! on the device - and not meta data ((dynamic) type information, 'present()'
+! status, array shape).
+!
+! Untested in this test case are:
+! - arrays with array descriptor
+! - polymorphic variables
+! - absent optional arguments
+!
+module target_procs
+ use iso_c_binding
+ implicit none
+ private
+ public :: copy3_array, copy3_scalar
+contains
+ subroutine copy3_array_int(from_intptr, to_intptr, N)
+ !$omp declare target
+ !type(c_ptr), value :: from, to
+ integer(c_intptr_t), value :: from_intptr, to_intptr ! VALUE issue, cf. copy3_array
+ type(c_ptr) :: from, to
+ integer, value :: N
+
+ real(c_double), pointer :: from_ptr(:)
+ real(c_double), pointer :: to_ptr(:)
+ integer :: i
+
+ from = transfer(from_intptr, mold=from)
+ to = transfer(to_intptr, mold=to)
+ call c_f_pointer(from, from_ptr, shape=[N])
+ call c_f_pointer(to, to_ptr, shape=[N])
+
+ !$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_intptr, to_intptr)
+ !$omp declare target
+ !type(c_ptr), value :: from, to
+ integer(c_intptr_t), value :: from_intptr, to_intptr ! VALUE issue, cf. copy3_array
+ type(c_ptr) :: from, to
+
+ real(c_double), pointer :: from_ptr
+ real(c_double), pointer :: to_ptr
+
+ from = transfer(from_intptr, mold=from)
+ to = transfer(to_intptr, mold=to)
+ call c_f_pointer(from, from_ptr)
+ call c_f_pointer(to, to_ptr)
+
+ to_ptr = 3 * from_ptr
+ end subroutine copy3_scalar_int
+
+
+ subroutine copy3_array(from, to, N)
+ type(c_ptr) :: from, to
+ integer, value :: N
+! [OpenMP issue:] Would like to use the following but it is not permitted due to VALUE.
+! !$omp target is_device_ptr(from, to)
+! call copy3_array_int(from, to, N)
+! !$omp end target
+! Hence:
+ integer(c_intptr_t) :: from_intptr, to_intptr
+
+ from_intptr = transfer(from, mold=from_intptr)
+ to_intptr = transfer(to, mold=to_intptr)
+
+ !$omp target
+ call copy3_array_int(from_intptr, to_intptr, N)
+ !$omp end target
+ end subroutine copy3_array
+
+ subroutine copy3_scalar(from, to)
+ type(c_ptr), value :: from, to ! VALUE issue, cf. copy3_array above
+ integer(c_intptr_t) :: from_intptr, to_intptr
+
+ from_intptr = transfer(from, mold=from_intptr)
+ to_intptr = transfer(to, mold=to_intptr)
+
+ !$omp target
+ call copy3_scalar_int(from_intptr, to_intptr)
+ !$omp end target
+ end subroutine copy3_scalar
+end module target_procs
+
+
+
+! Test local dummy arguments (w/o optional)
+module test_dummies
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_call_1, test_dummy_call_2
+contains
+ subroutine test_dummy_call_1()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ allocate(cc, dd, ee, ff)
+
+ 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
+ gg = 77.0_c_double
+ hh = 88.0_c_double
+
+ call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_dummy_call_1
+
+ subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+ integer, value :: N
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ call copy3_scalar(c_loc(cc), c_loc(dd))
+ !$omp end target data
+ if (abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ call copy3_scalar(c_loc(ee), c_loc(ff))
+ !$omp end target data
+ if (abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
+ call copy3_array(c_loc(gg), c_loc(hh), N)
+ !$omp end target data
+ if (any(abs(gg - 77.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ end subroutine test_dummy_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_call_2()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_double), pointer :: gptr(:), hptr(:)
+
+ allocate(cc, dd, ee, ff)
+ call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ deallocate(ee, ff)
+ end subroutine test_dummy_call_2
+
+ subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_double), pointer :: gptr(:), hptr(:)
+
+ integer, value :: N
+
+ real(c_double) :: dummy
+
+ 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
+ gg = 777.0_c_double
+ hh = 888.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+
+ !$omp target data map(to:cc) map(from:dd)
+ !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
+ c_cptr = c_loc(cc)
+ c_dptr = c_loc(dd)
+ cptr => cc
+ dptr => dd
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_loc(cptr), c_loc(dptr))
+ !$omp target update from(dd)
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+ !$omp end target data
+
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) call abort()
+
+
+ !$omp target data map(to:ee) map(from:ff)
+ !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_loc(eptr), c_loc(fptr))
+ !$omp target update from(ff)
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) call abort()
+ !$omp end target data
+
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh)
+ !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
+ c_gptr = c_loc(gg)
+ c_hptr = c_loc(hh)
+ gptr => gg
+ hptr => hh
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ gg = 7777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 7777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+
+ ! check Fortran pointer after target-value modification
+ gg = 77777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_loc(gptr), c_loc(hptr), N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ !$omp end target data
+
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ end subroutine test_dummy_callee_2
+end module test_dummies
+
+
+
+! Test local dummy arguments + VALUE (w/o optional)
+module test_dummies_value
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_val_call_1, test_dummy_val_call_2
+contains
+ subroutine test_dummy_val_call_1()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_double), target :: aa, bb
+
+ aa = 11.0_c_double
+ bb = 22.0_c_double
+
+ call test_dummy_val_callee_1(aa, bb)
+ end subroutine test_dummy_val_call_1
+
+ subroutine test_dummy_val_callee_1(aa, bb)
+ ! scalars
+ real(c_double), value, target :: aa, bb
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ end subroutine test_dummy_val_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_val_call_2()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_double), target :: aa, bb
+ type(c_ptr) :: c_aptr, c_bptr
+ real(c_double), pointer :: aptr, bptr
+
+ call test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ end subroutine test_dummy_val_call_2
+
+ subroutine test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ real(c_double), value, target :: aa, bb
+ type(c_ptr), value :: c_aptr, c_bptr
+ real(c_double), pointer :: aptr, bptr
+
+ real(c_double) :: dummy
+
+ aa = 111.0_c_double
+ bb = 222.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ end subroutine test_dummy_val_callee_2
+end module test_dummies_value
+
+
+
+! Test local dummy arguments + OPTIONAL
+! Values present and ptr associated to nonzero
+module test_dummies_opt
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_opt_call_1, test_dummy_opt_call_2
+contains
+ subroutine test_dummy_opt_call_1()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ allocate(cc, dd, ee, ff)
+
+ 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
+ gg = 77.0_c_double
+ hh = 88.0_c_double
+
+ call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_dummy_opt_call_1
+
+ subroutine test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ ! scalars
+ real(c_double), optional, target :: aa, bb
+ real(c_double), optional, target, allocatable :: cc, dd
+ real(c_double), optional, pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), optional, target :: gg(N), hh(N)
+ integer, value :: N
+
+ ! All shall be present - and pointing to non-NULL
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
+ call copy3_scalar(c_loc(cc), c_loc(dd))
+ !$omp end target data
+ if (abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
+ call copy3_scalar(c_loc(ee), c_loc(ff))
+ !$omp end target data
+ if (abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+ if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
+ call copy3_array(c_loc(gg), c_loc(hh), N)
+ !$omp end target data
+ if (any(abs(gg - 77.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ end subroutine test_dummy_opt_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_opt_call_2()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_double), pointer :: gptr(:), hptr(:)
+
+ allocate(cc, dd, ee, ff)
+ call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ deallocate(ee, ff)
+ end subroutine test_dummy_opt_call_2
+
+ subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ ! scalars
+ real(c_double), optional, target :: aa, bb
+ real(c_double), optional, target, allocatable :: cc, dd
+ real(c_double), optional, pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), optional, target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_double), optional, pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_double), optional, pointer :: gptr(:), hptr(:)
+
+ integer, value :: N
+
+ real(c_double) :: dummy
+
+ ! All shall be present - and pointing to non-NULL
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+
+ 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
+ gg = 777.0_c_double
+ hh = 888.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
+ if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
+ !$omp end target data
+
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
+ if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+
+ !$omp target data map(to:cc) map(from:dd)
+ !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
+ c_cptr = c_loc(cc)
+ c_dptr = c_loc(dd)
+ cptr => cc
+ dptr => dd
+ if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) call abort()
+ if (.not.associated(cptr) .or. .not.associated(dptr)) call abort()
+ !$omp end target data
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
+ if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) call abort()
+ if (.not.associated(cptr) .or. .not.associated(dptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_loc(cptr), c_loc(dptr))
+ !$omp target update from(dd)
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+ !$omp end target data
+
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) call abort()
+
+
+ !$omp target data map(to:ee) map(from:ff)
+ !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) call abort()
+ if (.not.associated(eptr) .or. .not.associated(fptr)) call abort()
+ !$omp end target data
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
+ if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) call abort()
+ if (.not.associated(eptr) .or. .not.associated(fptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_loc(eptr), c_loc(fptr))
+ !$omp target update from(ff)
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) call abort()
+ !$omp end target data
+
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh)
+ !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+ if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
+ c_gptr = c_loc(gg)
+ c_hptr = c_loc(hh)
+ gptr => gg
+ hptr => hh
+ if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) call abort()
+ if (.not.associated(gptr) .or. .not.associated(hptr)) call abort()
+ !$omp end target data
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+ if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
+ if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) call abort()
+ if (.not.associated(gptr) .or. .not.associated(hptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ gg = 7777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 7777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+
+ ! check Fortran pointer after target-value modification
+ gg = 77777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_loc(gptr), c_loc(hptr), N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ !$omp end target data
+
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ end subroutine test_dummy_opt_callee_2
+end module test_dummies_opt
+
+
+
+! Test local dummy arguments + OPTIONAL + VALUE
+! Values present
+module test_dummies_opt_value
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_opt_val_call_1, test_dummy_opt_val_call_2
+contains
+ subroutine test_dummy_opt_val_call_1()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_double), target :: aa, bb
+
+ aa = 11.0_c_double
+ bb = 22.0_c_double
+
+ call test_dummy_opt_val_callee_1(aa, bb)
+ end subroutine test_dummy_opt_val_call_1
+
+ subroutine test_dummy_opt_val_callee_1(aa, bb)
+ ! scalars
+ real(c_double), optional, value, target :: aa, bb
+
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ end subroutine test_dummy_opt_val_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_opt_val_call_2()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_double), target :: aa, bb
+ type(c_ptr) :: c_aptr, c_bptr
+ real(c_double), pointer :: aptr, bptr
+
+ call test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ end subroutine test_dummy_opt_val_call_2
+
+ subroutine test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ real(c_double), optional, value, target :: aa, bb
+ type(c_ptr), optional, value :: c_aptr, c_bptr
+ real(c_double), optional, pointer :: aptr, bptr
+
+ real(c_double) :: dummy
+
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
+ if (.not.present(aptr) .or. .not.present(bptr)) call abort()
+
+ aa = 111.0_c_double
+ bb = 222.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
+ if (.not.present(aptr) .or. .not.present(bptr)) call abort()
+
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
+ if (.not.present(aptr) .or. .not.present(bptr)) call abort()
+
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
+ if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ end subroutine test_dummy_opt_val_callee_2
+end module test_dummies_opt_value
+
+
+
+! Test nullptr
+module test_nullptr
+ use iso_c_binding
+ implicit none
+ private
+ public :: test_nullptr_1
+contains
+ subroutine test_nullptr_1()
+ ! scalars
+ real(c_double), pointer :: aa, bb
+ real(c_double), pointer :: ee, ff
+
+ type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr
+ real(c_double), pointer :: aptr, bptr, eptr, fptr
+
+ aa => null()
+ bb => null()
+ ee => null()
+ ff => null()
+
+ if (associated(aa) .or. associated(bb)) call abort()
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (c_associated(c_loc(aa)) .or. c_associated(c_loc(bb))) call abort()
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ if (c_associated(c_aptr) .or. c_associated(c_bptr)) call abort()
+ if (associated(aptr) .or. associated(bptr, bb)) call abort()
+ !$omp end target data
+ if (c_associated(c_aptr) .or. c_associated(c_bptr)) call abort()
+ if (associated(aptr) .or. associated(bptr, bb)) call abort()
+
+ call test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
+ end subroutine test_nullptr_1
+
+ subroutine test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
+ ! scalars
+ real(c_double), optional, pointer :: ee, ff
+
+ type(c_ptr), optional :: c_eptr, c_fptr
+ real(c_double), optional, pointer :: eptr, fptr
+
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (associated(ee) .or. associated(ff)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (associated(ee) .or. associated(ff)) call abort()
+ if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) call abort()
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ if (c_associated(c_eptr) .or. c_associated(c_fptr)) call abort()
+ if (associated(eptr) .or. associated(fptr)) call abort()
+ !$omp end target data
+
+ if (c_associated(c_eptr) .or. c_associated(c_fptr)) call abort()
+ if (associated(eptr) .or. associated(fptr)) call abort()
+ end subroutine test_dummy_opt_nullptr_callee_1
+end module test_nullptr
+
+
+
+! Test local variables
+module tests
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_main_1, test_main_2
+contains
+ ! map + use_device_addr + c_loc
+ subroutine test_main_1()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ allocate(cc, dd, ee, ff)
+
+
+ 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
+ gg = 77.0_c_double
+ hh = 88.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ call copy3_scalar(c_loc(cc), c_loc(dd))
+ !$omp end target data
+ if (abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ call copy3_scalar(c_loc(ee), c_loc(ff))
+ !$omp end target data
+ if (abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
+ call copy3_array(c_loc(gg), c_loc(hh), N)
+ !$omp end target data
+ if (any(abs(gg - 77.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_main_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_main_2
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_double), target :: aa, bb
+ real(c_double), target, allocatable :: cc, dd
+ real(c_double), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_double), target :: gg(N), hh(N)
+
+ real(c_double) :: dummy
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_double), pointer :: gptr(:), hptr(:)
+
+ allocate(cc, dd, ee, ff)
+
+ 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
+ gg = 777.0_c_double
+ hh = 888.0_c_double
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
+ if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
+
+
+ !$omp target data map(to:cc) map(from:dd)
+ !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
+ c_cptr = c_loc(cc)
+ c_dptr = c_loc(dd)
+ cptr => cc
+ dptr => dd
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_double
+ !$omp target update to(cc)
+ call copy3_scalar(c_loc(cptr), c_loc(dptr))
+ !$omp target update from(dd)
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
+ !$omp end target data
+
+ if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) call abort()
+ if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) call abort()
+
+
+ !$omp target data map(to:ee) map(from:ff)
+ !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_double
+ !$omp target update to(ee)
+ call copy3_scalar(c_loc(eptr), c_loc(fptr))
+ !$omp target update from(ff)
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) call abort()
+ !$omp end target data
+
+ if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
+ if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh)
+ !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
+ c_gptr = c_loc(gg)
+ c_hptr = c_loc(hh)
+ gptr => gg
+ hptr => hh
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ gg = 7777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 7777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+
+ ! check Fortran pointer after target-value modification
+ gg = 77777.0_c_double
+ !$omp target update to(gg)
+ call copy3_array(c_loc(gptr), c_loc(hptr), N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+ !$omp end target data
+
+ if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
+
+ deallocate(ee, ff)
+ end subroutine test_main_2
+end module tests
+
+
+program omp_device_addr
+ use tests
+ use test_dummies
+ use test_dummies_value
+ use test_dummies_opt
+ use test_dummies_opt_value
+ use test_nullptr
+ implicit none
+
+ call test_main_1()
+ call test_main_2()
+
+ call test_dummy_call_1()
+ call test_dummy_call_2()
+
+ call test_dummy_val_call_1()
+ call test_dummy_val_call_2()
+
+ call test_dummy_opt_call_1()
+ call test_dummy_opt_call_2()
+
+ call test_dummy_opt_val_call_1()
+ call test_dummy_opt_val_call_2()
+
+ call test_nullptr_1()
+end program omp_device_addr
diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90
new file mode 100644
index 00000000000..873700105b6
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90
@@ -0,0 +1,1202 @@
+! Comprehensive run-time test for use_device_addr
+!
+! Differs from use_device_addr-1.f90 by using a 4-byte variable (c_float)
+!
+! This test case assumes that a 'var' appearing in 'use_device_addr' is
+! only used as 'c_loc(var)' - such that only the actual data is used/usable
+! on the device - and not meta data ((dynamic) type information, 'present()'
+! status, array shape).
+!
+! Untested in this test case are:
+! - arrays with array descriptor
+! - polymorphic variables
+! - absent optional arguments
+!
+module target_procs
+ use iso_c_binding
+ implicit none
+ private
+ public :: copy3_array, copy3_scalar
+contains
+ subroutine copy3_array_int(from_intptr, to_intptr, N)
+ !$omp declare target
+ !type(c_ptr), value :: from, to
+ integer(c_intptr_t), value :: from_intptr, to_intptr ! VALUE issue, cf. copy3_array
+ type(c_ptr) :: from, to
+ integer, value :: N
+
+ real(c_float), pointer :: from_ptr(:)
+ real(c_float), pointer :: to_ptr(:)
+ integer :: i
+
+ from = transfer(from_intptr, mold=from)
+ to = transfer(to_intptr, mold=to)
+ call c_f_pointer(from, from_ptr, shape=[N])
+ call c_f_pointer(to, to_ptr, shape=[N])
+
+ !$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_intptr, to_intptr)
+ !$omp declare target
+ !type(c_ptr), value :: from, to
+ integer(c_intptr_t), value :: from_intptr, to_intptr ! VALUE issue, cf. copy3_array
+ type(c_ptr) :: from, to
+
+ real(c_float), pointer :: from_ptr
+ real(c_float), pointer :: to_ptr
+
+ from = transfer(from_intptr, mold=from)
+ to = transfer(to_intptr, mold=to)
+ call c_f_pointer(from, from_ptr)
+ call c_f_pointer(to, to_ptr)
+
+ to_ptr = 3 * from_ptr
+ end subroutine copy3_scalar_int
+
+
+ subroutine copy3_array(from, to, N)
+ type(c_ptr) :: from, to
+ integer, value :: N
+! [OpenMP issue:] Would like to use the following but it is not permitted due to VALUE.
+! !$omp target is_device_ptr(from, to)
+! call copy3_array_int(from, to, N)
+! !$omp end target
+! Hence:
+ integer(c_intptr_t) :: from_intptr, to_intptr
+
+ from_intptr = transfer(from, mold=from_intptr)
+ to_intptr = transfer(to, mold=to_intptr)
+
+ !$omp target
+ call copy3_array_int(from_intptr, to_intptr, N)
+ !$omp end target
+ end subroutine copy3_array
+
+ subroutine copy3_scalar(from, to)
+ type(c_ptr), value :: from, to ! VALUE issue, cf. copy3_array above
+ integer(c_intptr_t) :: from_intptr, to_intptr
+
+ from_intptr = transfer(from, mold=from_intptr)
+ to_intptr = transfer(to, mold=to_intptr)
+
+ !$omp target
+ call copy3_scalar_int(from_intptr, to_intptr)
+ !$omp end target
+ end subroutine copy3_scalar
+end module target_procs
+
+
+
+! Test local dummy arguments (w/o optional)
+module test_dummies
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_call_1, test_dummy_call_2
+contains
+ subroutine test_dummy_call_1()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_float), target :: aa, bb
+ real(c_float), target, allocatable :: cc, dd
+ real(c_float), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_float), target :: gg(N), hh(N)
+
+ allocate(cc, dd, ee, ff)
+
+ aa = 11.0_c_float
+ bb = 22.0_c_float
+ cc = 33.0_c_float
+ dd = 44.0_c_float
+ ee = 55.0_c_float
+ ff = 66.0_c_float
+ gg = 77.0_c_float
+ hh = 88.0_c_float
+
+ call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_dummy_call_1
+
+ subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ ! scalars
+ real(c_float), target :: aa, bb
+ real(c_float), target, allocatable :: cc, dd
+ real(c_float), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_float), target :: gg(N), hh(N)
+ integer, value :: N
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ call copy3_scalar(c_loc(cc), c_loc(dd))
+ !$omp end target data
+ if (abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ call copy3_scalar(c_loc(ee), c_loc(ff))
+ !$omp end target data
+ if (abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
+ call copy3_array(c_loc(gg), c_loc(hh), N)
+ !$omp end target data
+ if (any(abs(gg - 77.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+ end subroutine test_dummy_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_call_2()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_float), target :: aa, bb
+ real(c_float), target, allocatable :: cc, dd
+ real(c_float), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_float), target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_float), pointer :: gptr(:), hptr(:)
+
+ allocate(cc, dd, ee, ff)
+ call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ deallocate(ee, ff)
+ end subroutine test_dummy_call_2
+
+ subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ ! scalars
+ real(c_float), target :: aa, bb
+ real(c_float), target, allocatable :: cc, dd
+ real(c_float), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_float), target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_float), pointer :: gptr(:), hptr(:)
+
+ integer, value :: N
+
+ real(c_float) :: dummy
+
+ aa = 111.0_c_float
+ bb = 222.0_c_float
+ cc = 333.0_c_float
+ dd = 444.0_c_float
+ ee = 555.0_c_float
+ ff = 666.0_c_float
+ gg = 777.0_c_float
+ hh = 888.0_c_float
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_float
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_float
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+
+ !$omp target data map(to:cc) map(from:dd)
+ !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
+ c_cptr = c_loc(cc)
+ c_dptr = c_loc(dd)
+ cptr => cc
+ dptr => dd
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_float
+ !$omp target update to(cc)
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_float
+ !$omp target update to(cc)
+ call copy3_scalar(c_loc(cptr), c_loc(dptr))
+ !$omp target update from(dd)
+ if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+ !$omp end target data
+
+ if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd)) call abort()
+
+
+ !$omp target data map(to:ee) map(from:ff)
+ !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_float
+ !$omp target update to(ee)
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_float
+ !$omp target update to(ee)
+ call copy3_scalar(c_loc(eptr), c_loc(fptr))
+ !$omp target update from(ff)
+ if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff)) call abort()
+ !$omp end target data
+
+ if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh)
+ !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
+ c_gptr = c_loc(gg)
+ c_hptr = c_loc(hh)
+ gptr => gg
+ hptr => hh
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(hh))) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ gg = 7777.0_c_float
+ !$omp target update to(gg)
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 7777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+
+ ! check Fortran pointer after target-value modification
+ gg = 77777.0_c_float
+ !$omp target update to(gg)
+ call copy3_array(c_loc(gptr), c_loc(hptr), N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+ !$omp end target data
+
+ if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+ end subroutine test_dummy_callee_2
+end module test_dummies
+
+
+
+! Test local dummy arguments + VALUE (w/o optional)
+module test_dummies_value
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_val_call_1, test_dummy_val_call_2
+contains
+ subroutine test_dummy_val_call_1()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_float), target :: aa, bb
+
+ aa = 11.0_c_float
+ bb = 22.0_c_float
+
+ call test_dummy_val_callee_1(aa, bb)
+ end subroutine test_dummy_val_call_1
+
+ subroutine test_dummy_val_callee_1(aa, bb)
+ ! scalars
+ real(c_float), value, target :: aa, bb
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+ end subroutine test_dummy_val_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_val_call_2()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_float), target :: aa, bb
+ type(c_ptr) :: c_aptr, c_bptr
+ real(c_float), pointer :: aptr, bptr
+
+ call test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ end subroutine test_dummy_val_call_2
+
+ subroutine test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ real(c_float), value, target :: aa, bb
+ type(c_ptr), value :: c_aptr, c_bptr
+ real(c_float), pointer :: aptr, bptr
+
+ real(c_float) :: dummy
+
+ aa = 111.0_c_float
+ bb = 222.0_c_float
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_float
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_float
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+ end subroutine test_dummy_val_callee_2
+end module test_dummies_value
+
+
+
+! Test local dummy arguments + OPTIONAL
+! Values present and ptr associated to nonzero
+module test_dummies_opt
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_opt_call_1, test_dummy_opt_call_2
+contains
+ subroutine test_dummy_opt_call_1()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_float), target :: aa, bb
+ real(c_float), target, allocatable :: cc, dd
+ real(c_float), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_float), target :: gg(N), hh(N)
+
+ allocate(cc, dd, ee, ff)
+
+ aa = 11.0_c_float
+ bb = 22.0_c_float
+ cc = 33.0_c_float
+ dd = 44.0_c_float
+ ee = 55.0_c_float
+ ff = 66.0_c_float
+ gg = 77.0_c_float
+ hh = 88.0_c_float
+
+ call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_dummy_opt_call_1
+
+ subroutine test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
+ ! scalars
+ real(c_float), optional, target :: aa, bb
+ real(c_float), optional, target, allocatable :: cc, dd
+ real(c_float), optional, pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_float), optional, target :: gg(N), hh(N)
+ integer, value :: N
+
+ ! All shall be present - and pointing to non-NULL
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
+ call copy3_scalar(c_loc(cc), c_loc(dd))
+ !$omp end target data
+ if (abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
+ call copy3_scalar(c_loc(ee), c_loc(ff))
+ !$omp end target data
+ if (abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+ !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+ if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
+ call copy3_array(c_loc(gg), c_loc(hh), N)
+ !$omp end target data
+ if (any(abs(gg - 77.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+ end subroutine test_dummy_opt_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_opt_call_2()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_float), target :: aa, bb
+ real(c_float), target, allocatable :: cc, dd
+ real(c_float), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_float), target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_float), pointer :: gptr(:), hptr(:)
+
+ allocate(cc, dd, ee, ff)
+ call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ deallocate(ee, ff)
+ end subroutine test_dummy_opt_call_2
+
+ subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
+ N)
+ ! scalars
+ real(c_float), optional, target :: aa, bb
+ real(c_float), optional, target, allocatable :: cc, dd
+ real(c_float), optional, pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_float), optional, target :: gg(N), hh(N)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_float), optional, pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_float), optional, pointer :: gptr(:), hptr(:)
+
+ integer, value :: N
+
+ real(c_float) :: dummy
+
+ ! All shall be present - and pointing to non-NULL
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+
+ aa = 111.0_c_float
+ bb = 222.0_c_float
+ cc = 333.0_c_float
+ dd = 444.0_c_float
+ ee = 555.0_c_float
+ ff = 666.0_c_float
+ gg = 777.0_c_float
+ hh = 888.0_c_float
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
+ if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
+ !$omp end target data
+
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
+ if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_float
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_float
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+
+ !$omp target data map(to:cc) map(from:dd)
+ !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
+ c_cptr = c_loc(cc)
+ c_dptr = c_loc(dd)
+ cptr => cc
+ dptr => dd
+ if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) call abort()
+ if (.not.associated(cptr) .or. .not.associated(dptr)) call abort()
+ !$omp end target data
+ if (.not.present(cc) .or. .not.present(dd)) call abort()
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
+ if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) call abort()
+ if (.not.associated(cptr) .or. .not.associated(dptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_float
+ !$omp target update to(cc)
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_float
+ !$omp target update to(cc)
+ call copy3_scalar(c_loc(cptr), c_loc(dptr))
+ !$omp target update from(dd)
+ if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+ !$omp end target data
+
+ if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd)) call abort()
+
+
+ !$omp target data map(to:ee) map(from:ff)
+ !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) call abort()
+ if (.not.associated(eptr) .or. .not.associated(fptr)) call abort()
+ !$omp end target data
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (.not.associated(ee) .or. .not.associated(ff)) call abort()
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
+ if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) call abort()
+ if (.not.associated(eptr) .or. .not.associated(fptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_float
+ !$omp target update to(ee)
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_float
+ !$omp target update to(ee)
+ call copy3_scalar(c_loc(eptr), c_loc(fptr))
+ !$omp target update from(ff)
+ if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff)) call abort()
+ !$omp end target data
+
+ if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh)
+ !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+ if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
+ c_gptr = c_loc(gg)
+ c_hptr = c_loc(hh)
+ gptr => gg
+ hptr => hh
+ if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) call abort()
+ if (.not.associated(gptr) .or. .not.associated(hptr)) call abort()
+ !$omp end target data
+ if (.not.present(gg) .or. .not.present(hh)) call abort()
+ if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
+ if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) call abort()
+ if (.not.associated(gptr) .or. .not.associated(hptr)) call abort()
+
+ ! check c_loc ptr once
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(hh))) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ gg = 7777.0_c_float
+ !$omp target update to(gg)
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 7777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+
+ ! check Fortran pointer after target-value modification
+ gg = 77777.0_c_float
+ !$omp target update to(gg)
+ call copy3_array(c_loc(gptr), c_loc(hptr), N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+ !$omp end target data
+
+ if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+ end subroutine test_dummy_opt_callee_2
+end module test_dummies_opt
+
+
+
+! Test local dummy arguments + OPTIONAL + VALUE
+! Values present
+module test_dummies_opt_value
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_dummy_opt_val_call_1, test_dummy_opt_val_call_2
+contains
+ subroutine test_dummy_opt_val_call_1()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_float), target :: aa, bb
+
+ aa = 11.0_c_float
+ bb = 22.0_c_float
+
+ call test_dummy_opt_val_callee_1(aa, bb)
+ end subroutine test_dummy_opt_val_call_1
+
+ subroutine test_dummy_opt_val_callee_1(aa, bb)
+ ! scalars
+ real(c_float), optional, value, target :: aa, bb
+
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+ end subroutine test_dummy_opt_val_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_opt_val_call_2()
+ ! scalars - with value, neither allocatable nor pointer no dimension permitted
+ real(c_float), target :: aa, bb
+ type(c_ptr) :: c_aptr, c_bptr
+ real(c_float), pointer :: aptr, bptr
+
+ call test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ end subroutine test_dummy_opt_val_call_2
+
+ subroutine test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
+ real(c_float), optional, value, target :: aa, bb
+ type(c_ptr), optional, value :: c_aptr, c_bptr
+ real(c_float), optional, pointer :: aptr, bptr
+
+ real(c_float) :: dummy
+
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
+ if (.not.present(aptr) .or. .not.present(bptr)) call abort()
+
+ aa = 111.0_c_float
+ bb = 222.0_c_float
+
+ !$omp target data map(to:aa) map(from:bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
+ if (.not.present(aptr) .or. .not.present(bptr)) call abort()
+
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) call abort()
+ if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
+ if (.not.present(aptr) .or. .not.present(bptr)) call abort()
+
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
+ if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_float
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_float
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+ end subroutine test_dummy_opt_val_callee_2
+end module test_dummies_opt_value
+
+
+
+! Test nullptr
+module test_nullptr
+ use iso_c_binding
+ implicit none
+ private
+ public :: test_nullptr_1
+contains
+ subroutine test_nullptr_1()
+ ! scalars
+ real(c_float), pointer :: aa, bb
+ real(c_float), pointer :: ee, ff
+
+ type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr
+ real(c_float), pointer :: aptr, bptr, eptr, fptr
+
+ aa => null()
+ bb => null()
+ ee => null()
+ ff => null()
+
+ if (associated(aa) .or. associated(bb)) call abort()
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (c_associated(c_loc(aa)) .or. c_associated(c_loc(bb))) call abort()
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ if (c_associated(c_aptr) .or. c_associated(c_bptr)) call abort()
+ if (associated(aptr) .or. associated(bptr, bb)) call abort()
+ !$omp end target data
+ if (c_associated(c_aptr) .or. c_associated(c_bptr)) call abort()
+ if (associated(aptr) .or. associated(bptr, bb)) call abort()
+
+ call test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
+ end subroutine test_nullptr_1
+
+ subroutine test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
+ ! scalars
+ real(c_float), optional, pointer :: ee, ff
+
+ type(c_ptr), optional :: c_eptr, c_fptr
+ real(c_float), optional, pointer :: eptr, fptr
+
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (associated(ee) .or. associated(ff)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) call abort()
+ if (associated(ee) .or. associated(ff)) call abort()
+ if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) call abort()
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ if (c_associated(c_eptr) .or. c_associated(c_fptr)) call abort()
+ if (associated(eptr) .or. associated(fptr)) call abort()
+ !$omp end target data
+
+ if (c_associated(c_eptr) .or. c_associated(c_fptr)) call abort()
+ if (associated(eptr) .or. associated(fptr)) call abort()
+ end subroutine test_dummy_opt_nullptr_callee_1
+end module test_nullptr
+
+
+
+! Test local variables
+module tests
+ use iso_c_binding
+ use target_procs
+ implicit none
+ private
+ public :: test_main_1, test_main_2
+contains
+ ! map + use_device_addr + c_loc
+ subroutine test_main_1()
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_float), target :: aa, bb
+ real(c_float), target, allocatable :: cc, dd
+ real(c_float), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_float), target :: gg(N), hh(N)
+
+ allocate(cc, dd, ee, ff)
+
+
+ aa = 11.0_c_float
+ bb = 22.0_c_float
+ cc = 33.0_c_float
+ dd = 44.0_c_float
+ ee = 55.0_c_float
+ ff = 66.0_c_float
+ gg = 77.0_c_float
+ hh = 88.0_c_float
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_scalar(c_loc(aa), c_loc(bb))
+ !$omp end target data
+ if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ call copy3_scalar(c_loc(cc), c_loc(dd))
+ !$omp end target data
+ if (abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ call copy3_scalar(c_loc(ee), c_loc(ff))
+ !$omp end target data
+ if (abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
+ call copy3_array(c_loc(gg), c_loc(hh), N)
+ !$omp end target data
+ if (any(abs(gg - 77.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_main_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_main_2
+ integer, parameter :: N = 1000
+
+ ! scalars
+ real(c_float), target :: aa, bb
+ real(c_float), target, allocatable :: cc, dd
+ real(c_float), pointer :: ee, ff
+
+ ! non-descriptor arrays
+ real(c_float), target :: gg(N), hh(N)
+
+ real(c_float) :: dummy
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
+ real(c_float), pointer :: gptr(:), hptr(:)
+
+ allocate(cc, dd, ee, ff)
+
+ aa = 111.0_c_float
+ bb = 222.0_c_float
+ cc = 333.0_c_float
+ dd = 444.0_c_float
+ ee = 555.0_c_float
+ ff = 666.0_c_float
+ gg = 777.0_c_float
+ hh = 888.0_c_float
+
+ !$omp target data map(to:aa) map(from:bb)
+ !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
+ c_aptr = c_loc(aa)
+ c_bptr = c_loc(bb)
+ aptr => aa
+ bptr => bb
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_float
+ !$omp target update to(aa)
+ call copy3_scalar(c_aptr, c_bptr)
+ !$omp target update from(bb)
+ if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_float
+ !$omp target update to(aa)
+ call copy3_scalar(c_loc(aptr), c_loc(bptr))
+ !$omp target update from(bb)
+ if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+ !$omp end target data
+
+ if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
+ if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
+
+
+ !$omp target data map(to:cc) map(from:dd)
+ !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
+ c_cptr = c_loc(cc)
+ c_dptr = c_loc(dd)
+ cptr => cc
+ dptr => dd
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_float
+ !$omp target update to(cc)
+ call copy3_scalar(c_cptr, c_dptr)
+ !$omp target update from(dd)
+ if (abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_float
+ !$omp target update to(cc)
+ call copy3_scalar(c_loc(cptr), c_loc(dptr))
+ !$omp target update from(dd)
+ if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
+ !$omp end target data
+
+ if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd)) call abort()
+ if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd)) call abort()
+
+
+ !$omp target data map(to:ee) map(from:ff)
+ !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
+ c_eptr = c_loc(ee)
+ c_fptr = c_loc(ff)
+ eptr => ee
+ fptr => ff
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_float
+ !$omp target update to(ee)
+ call copy3_scalar(c_eptr, c_fptr)
+ !$omp target update from(ff)
+ if (abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_float
+ !$omp target update to(ee)
+ call copy3_scalar(c_loc(eptr), c_loc(fptr))
+ !$omp target update from(ff)
+ if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff)) call abort()
+ !$omp end target data
+
+ if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
+ if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
+
+
+ !$omp target data map(to:gg) map(from:hh)
+ !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
+ c_gptr = c_loc(gg)
+ c_hptr = c_loc(hh)
+ gptr => gg
+ hptr => hh
+ !$omp end target data
+
+ ! check c_loc ptr once
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(hh))) call abort()
+
+ ! check c_loc ptr again after target-value modification
+ gg = 7777.0_c_float
+ !$omp target update to(gg)
+ call copy3_array(c_gptr, c_hptr, N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 7777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+
+ ! check Fortran pointer after target-value modification
+ gg = 77777.0_c_float
+ !$omp target update to(gg)
+ call copy3_array(c_loc(gptr), c_loc(hptr), N)
+ !$omp target update from(hh)
+ if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+ !$omp end target data
+
+ if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
+ if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
+
+ deallocate(ee, ff)
+ end subroutine test_main_2
+end module tests
+
+
+program omp_device_addr
+ use tests
+ use test_dummies
+ use test_dummies_value
+ use test_dummies_opt
+ use test_dummies_opt_value
+ use test_nullptr
+ implicit none
+
+ call test_main_1()
+ call test_main_2()
+
+ call test_dummy_call_1()
+ call test_dummy_call_2()
+
+ call test_dummy_val_call_1()
+ call test_dummy_val_call_2()
+
+ call test_dummy_opt_call_1()
+ call test_dummy_opt_call_2()
+
+ call test_dummy_opt_val_call_1()
+ call test_dummy_opt_val_call_2()
+
+ call test_nullptr_1()
+end program omp_device_addr
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: [patch][OpenMP,Fortran] Fix several OpenMP use_device_addr/map/update errors found by a length test case
2019-10-07 23:12 ` [patch][OpenMP,Fortran] Fix several OpenMP use_device_addr/map/update errors found by a length test case Tobias Burnus
@ 2019-10-10 12:22 ` Jakub Jelinek
2019-10-10 16:53 ` Tobias Burnus
0 siblings, 1 reply; 6+ messages in thread
From: Jakub Jelinek @ 2019-10-10 12:22 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc-patches, fortran
On Tue, Oct 08, 2019 at 01:11:53AM +0200, Tobias Burnus wrote:
> gcc/fortran/
> * f95-lang.c (LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR): Re-define to
> gfc_omp_is_allocatable_or_ptr.
> * trans-decl.c (create_function_arglist): Set GFC_DECL_OPTIONAL_ARGUMENT
> only if not passed by value.
> * trans-openmp.c (gfc_omp_is_allocatable_or_ptr): New.
> (gfc_trans_omp_clauses): Actually pass use_device_addr on to the middle
> end; for MAP, handle (present) optional arguments; for target update,
> handle allocatable/pointer scalars.
> * trans.h (gfc_omp_is_allocatable_or_ptr): Declare.
>
> gcc/
> * langhooks-def.h (LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR): Define.
> (LANG_HOOKS_DECLS): Add it.
> * langhooks.h (lang_hooks_for_decls): Add omp_is_allocatable_or_ptr;
> update comment for omp_is_optional_argument.
> * omp-general.c (omp_is_allocatable_or_ptr): New.
> * omp-general.h (omp_is_allocatable_or_ptr): Declare.
> * omp-low.c (scan_sharing_clauses, lower_omp_target): Handle
> Fortran's optional arguments and allocatable/pointer scalars
> with use_device_addr.
This looks reasonable, with a small nit.
> libgomp/
> * testsuite/libgomp.fortran/use_device_addr-1.f90: New.
> * testsuite/libgomp.fortran/use_device_addr-2.f90: New.
I'm worried about the tests though.
> @@ -11678,7 +11680,18 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
> }
> else
> {
> - var = build_fold_addr_expr (var);
> + // While MAP is handled explicitly by the FE,
> + // for 'target update', only the identified is passed.
omp-low.c (like most of gcc/*.c) uses /* ... */ comments almost everywhere,
can you please just use the same here?
Otherwise the non-test part LGTM.
What worries me about the test is that the officially only portable way
to use it in a target region is is_device_ptr. I believe the intention was
to allow the implementation to transform the pointers from e.g.
use_device_ptr to whatever the implementation wants, where it could be e.g.
a structure containing pointer and something or whatever and is_device_ptr
actually finishing it up, even when in our implementation is_device_ptr is
basically just copying the pointer bits from host to device (==
firstprivate).
Yes, I know there is the restriction that the is_device_ptr list item must
be a dummy variable without VALUE/ALLOCATABLE/POINTER. VALUE itself
wouldn't be a big deal, we could call just by reference instead of value,
but allocatable/pointer I bet is a problem. So, if there is no portable
way in Fortran to pass c_loc result as a dummy argument to some subprogram
where the dummy argument is not allocatable/pointer, and the caller doesn't
access the actual data in any way, I'm afraid we need to do what you are
doing. But then the test should start with a comment that it is not
portable and assumes that is_device_ptr doesn't need to transform the
use_device_ptr addresses in any way. Or another option would be to use C
code for the actual target region, c_loc is for C pointers and if you pass
to C code the c_loc as a pointer and pass in the array size/whatever else it
needs to know, it can then implement it portably with is_device_ptr clause
on the C pointer.
Jakub
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: [patch][OpenMP,Fortran] Fix several OpenMP use_device_addr/map/update errors found by a length test case
2019-10-10 12:22 ` Jakub Jelinek
@ 2019-10-10 16:53 ` Tobias Burnus
2019-10-10 16:55 ` Jakub Jelinek
2019-10-10 17:06 ` Janne Blomqvist
0 siblings, 2 replies; 6+ messages in thread
From: Tobias Burnus @ 2019-10-10 16:53 UTC (permalink / raw)
To: Jakub Jelinek, Tobias Burnus; +Cc: gcc-patches, fortran
[-- Attachment #1: Type: text/plain, Size: 913 bytes --]
Hi Jakub,
On 10/10/19 1:55 PM, Jakub Jelinek wrote:
> What worries me about the test is that the officially only portable way
> to use it in a target region is is_device_ptr.
How about the attached test cases? The only difference is in "module
target_procs".
OK now?
Still, I hope the next round of the OpenMP spec permits additionally
"type(c_ptr)" – locally defined or as dummy argument with value attribute.
Tobias
PS: is_device_ptr(scalar_real_dummy) crashes as one does a dereference
too much. I make a detour by creating a 1-element array out the
c-pointer. That's not nice but I believe it is standard conform. In any
case, I would prefer to defer modifying the code for is_device_ptr
and/or use_device_ptr to another round. (And I need also to get a better
understanding what is_device_ptr should actually accept as argument and
do with it. It is as unclear to me as use_device_ptr.)
[-- Attachment #2: use_device_addr-1.f90 --]
[-- Type: text/x-fortran, Size: 44984 bytes --]
! Comprehensive run-time test for use_device_addr
!
! Differs from use_device_addr-2.f90 by using a 8-byte variable (c_double)
!
! This test case assumes that a 'var' appearing in 'use_device_addr' is
! only used as 'c_loc(var)' - such that only the actual data is used/usable
! on the device - and not meta data ((dynamic) type information, 'present()'
! status, array shape).
!
! Untested in this test case are:
! - arrays with array descriptor
! - polymorphic variables
! - absent optional arguments
!
module target_procs
use iso_c_binding
implicit none
private
public :: copy3_array, copy3_scalar
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
end module target_procs
! Test local dummy arguments (w/o optional)
module test_dummies
use iso_c_binding
use target_procs
implicit none
private
public :: test_dummy_call_1, test_dummy_call_2
contains
subroutine test_dummy_call_1()
integer, parameter :: N = 1000
! scalars
real(c_double), target :: aa, bb
real(c_double), target, allocatable :: cc, dd
real(c_double), pointer :: ee, ff
! non-descriptor arrays
real(c_double), target :: gg(N), hh(N)
allocate(cc, dd, ee, ff)
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
gg = 77.0_c_double
hh = 88.0_c_double
call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
deallocate(ee, ff) ! pointers, only
end subroutine test_dummy_call_1
subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
! scalars
real(c_double), target :: aa, bb
real(c_double), target, allocatable :: cc, dd
real(c_double), pointer :: ee, ff
! non-descriptor arrays
real(c_double), target :: gg(N), hh(N)
integer, value :: N
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
call copy3_scalar(c_loc(aa), c_loc(bb))
!$omp end target data
if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
call copy3_scalar(c_loc(cc), c_loc(dd))
!$omp end target data
if (abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
call copy3_scalar(c_loc(ee), c_loc(ff))
!$omp end target data
if (abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
call copy3_array(c_loc(gg), c_loc(hh), N)
!$omp end target data
if (any(abs(gg - 77.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
end subroutine test_dummy_callee_1
! Save device ptr - and recall pointer
subroutine test_dummy_call_2()
integer, parameter :: N = 1000
! scalars
real(c_double), target :: aa, bb
real(c_double), target, allocatable :: cc, dd
real(c_double), pointer :: ee, ff
! non-descriptor arrays
real(c_double), target :: gg(N), hh(N)
type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
real(c_double), pointer :: gptr(:), hptr(:)
allocate(cc, dd, ee, ff)
call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
N)
deallocate(ee, ff)
end subroutine test_dummy_call_2
subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
N)
! scalars
real(c_double), target :: aa, bb
real(c_double), target, allocatable :: cc, dd
real(c_double), pointer :: ee, ff
! non-descriptor arrays
real(c_double), target :: gg(N), hh(N)
type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
real(c_double), pointer :: gptr(:), hptr(:)
integer, value :: N
real(c_double) :: dummy
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
gg = 777.0_c_double
hh = 888.0_c_double
!$omp target data map(to:aa) map(from:bb)
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
! check c_loc ptr again after target-value modification
aa = 1111.0_c_double
!$omp target update to(aa)
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
! check Fortran pointer after target-value modification
aa = 11111.0_c_double
!$omp target update to(aa)
call copy3_scalar(c_loc(aptr), c_loc(bptr))
!$omp target update from(bb)
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp end target data
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd)
!$omp target data map(alloc:dummy) use_device_addr(cc,dd)
c_cptr = c_loc(cc)
c_dptr = c_loc(dd)
cptr => cc
dptr => dd
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
! check c_loc ptr again after target-value modification
cc = 3333.0_c_double
!$omp target update to(cc)
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
! check Fortran pointer after target-value modification
cc = 33333.0_c_double
!$omp target update to(cc)
call copy3_scalar(c_loc(cptr), c_loc(dptr))
!$omp target update from(dd)
if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
!$omp end target data
if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) call abort()
!$omp target data map(to:ee) map(from:ff)
!$omp target data map(alloc:dummy) use_device_addr(ee,ff)
c_eptr = c_loc(ee)
c_fptr = c_loc(ff)
eptr => ee
fptr => ff
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
! check c_loc ptr again after target-value modification
ee = 5555.0_c_double
!$omp target update to(ee)
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
! check Fortran pointer after target-value modification
ee = 55555.0_c_double
!$omp target update to(ee)
call copy3_scalar(c_loc(eptr), c_loc(fptr))
!$omp target update from(ff)
if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) call abort()
!$omp end target data
if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh)
!$omp target data map(alloc:dummy) use_device_addr(gg,hh)
c_gptr = c_loc(gg)
c_hptr = c_loc(hh)
gptr => gg
hptr => hh
!$omp end target data
! check c_loc ptr once
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) call abort()
! check c_loc ptr again after target-value modification
gg = 7777.0_c_double
!$omp target update to(gg)
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 7777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
! check Fortran pointer after target-value modification
gg = 77777.0_c_double
!$omp target update to(gg)
call copy3_array(c_loc(gptr), c_loc(hptr), N)
!$omp target update from(hh)
if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
!$omp end target data
if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
end subroutine test_dummy_callee_2
end module test_dummies
! Test local dummy arguments + VALUE (w/o optional)
module test_dummies_value
use iso_c_binding
use target_procs
implicit none
private
public :: test_dummy_val_call_1, test_dummy_val_call_2
contains
subroutine test_dummy_val_call_1()
! scalars - with value, neither allocatable nor pointer no dimension permitted
real(c_double), target :: aa, bb
aa = 11.0_c_double
bb = 22.0_c_double
call test_dummy_val_callee_1(aa, bb)
end subroutine test_dummy_val_call_1
subroutine test_dummy_val_callee_1(aa, bb)
! scalars
real(c_double), value, target :: aa, bb
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
call copy3_scalar(c_loc(aa), c_loc(bb))
!$omp end target data
if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
end subroutine test_dummy_val_callee_1
! Save device ptr - and recall pointer
subroutine test_dummy_val_call_2()
! scalars - with value, neither allocatable nor pointer no dimension permitted
real(c_double), target :: aa, bb
type(c_ptr) :: c_aptr, c_bptr
real(c_double), pointer :: aptr, bptr
call test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
end subroutine test_dummy_val_call_2
subroutine test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
real(c_double), value, target :: aa, bb
type(c_ptr), value :: c_aptr, c_bptr
real(c_double), pointer :: aptr, bptr
real(c_double) :: dummy
aa = 111.0_c_double
bb = 222.0_c_double
!$omp target data map(to:aa) map(from:bb)
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
! check c_loc ptr again after target-value modification
aa = 1111.0_c_double
!$omp target update to(aa)
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
! check Fortran pointer after target-value modification
aa = 11111.0_c_double
!$omp target update to(aa)
call copy3_scalar(c_loc(aptr), c_loc(bptr))
!$omp target update from(bb)
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp end target data
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
end subroutine test_dummy_val_callee_2
end module test_dummies_value
! Test local dummy arguments + OPTIONAL
! Values present and ptr associated to nonzero
module test_dummies_opt
use iso_c_binding
use target_procs
implicit none
private
public :: test_dummy_opt_call_1, test_dummy_opt_call_2
contains
subroutine test_dummy_opt_call_1()
integer, parameter :: N = 1000
! scalars
real(c_double), target :: aa, bb
real(c_double), target, allocatable :: cc, dd
real(c_double), pointer :: ee, ff
! non-descriptor arrays
real(c_double), target :: gg(N), hh(N)
allocate(cc, dd, ee, ff)
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
gg = 77.0_c_double
hh = 88.0_c_double
call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
deallocate(ee, ff) ! pointers, only
end subroutine test_dummy_opt_call_1
subroutine test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
! scalars
real(c_double), optional, target :: aa, bb
real(c_double), optional, target, allocatable :: cc, dd
real(c_double), optional, pointer :: ee, ff
! non-descriptor arrays
real(c_double), optional, target :: gg(N), hh(N)
integer, value :: N
! All shall be present - and pointing to non-NULL
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.present(cc) .or. .not.present(dd)) call abort()
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (.not.present(gg) .or. .not.present(hh)) call abort()
if (.not.associated(ee) .or. .not.associated(ff)) call abort()
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
call copy3_scalar(c_loc(aa), c_loc(bb))
!$omp end target data
if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
if (.not.present(cc) .or. .not.present(dd)) call abort()
if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
call copy3_scalar(c_loc(cc), c_loc(dd))
!$omp end target data
if (abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (.not.associated(ee) .or. .not.associated(ff)) call abort()
if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
call copy3_scalar(c_loc(ee), c_loc(ff))
!$omp end target data
if (abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
if (.not.present(gg) .or. .not.present(hh)) call abort()
if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
call copy3_array(c_loc(gg), c_loc(hh), N)
!$omp end target data
if (any(abs(gg - 77.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
end subroutine test_dummy_opt_callee_1
! Save device ptr - and recall pointer
subroutine test_dummy_opt_call_2()
integer, parameter :: N = 1000
! scalars
real(c_double), target :: aa, bb
real(c_double), target, allocatable :: cc, dd
real(c_double), pointer :: ee, ff
! non-descriptor arrays
real(c_double), target :: gg(N), hh(N)
type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
real(c_double), pointer :: gptr(:), hptr(:)
allocate(cc, dd, ee, ff)
call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
N)
deallocate(ee, ff)
end subroutine test_dummy_opt_call_2
subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
N)
! scalars
real(c_double), optional, target :: aa, bb
real(c_double), optional, target, allocatable :: cc, dd
real(c_double), optional, pointer :: ee, ff
! non-descriptor arrays
real(c_double), optional, target :: gg(N), hh(N)
type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
real(c_double), optional, pointer :: aptr, bptr, cptr, dptr, eptr, fptr
real(c_double), optional, pointer :: gptr(:), hptr(:)
integer, value :: N
real(c_double) :: dummy
! All shall be present - and pointing to non-NULL
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.present(cc) .or. .not.present(dd)) call abort()
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (.not.present(gg) .or. .not.present(hh)) call abort()
if (.not.associated(ee) .or. .not.associated(ff)) call abort()
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
gg = 777.0_c_double
hh = 888.0_c_double
!$omp target data map(to:aa) map(from:bb)
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
!$omp end target data
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
! check c_loc ptr once
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
! check c_loc ptr again after target-value modification
aa = 1111.0_c_double
!$omp target update to(aa)
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
! check Fortran pointer after target-value modification
aa = 11111.0_c_double
!$omp target update to(aa)
call copy3_scalar(c_loc(aptr), c_loc(bptr))
!$omp target update from(bb)
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp end target data
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd)
!$omp target data map(alloc:dummy) use_device_addr(cc,dd)
if (.not.present(cc) .or. .not.present(dd)) call abort()
if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
c_cptr = c_loc(cc)
c_dptr = c_loc(dd)
cptr => cc
dptr => dd
if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) call abort()
if (.not.associated(cptr) .or. .not.associated(dptr)) call abort()
!$omp end target data
if (.not.present(cc) .or. .not.present(dd)) call abort()
if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) call abort()
if (.not.associated(cptr) .or. .not.associated(dptr)) call abort()
! check c_loc ptr once
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
! check c_loc ptr again after target-value modification
cc = 3333.0_c_double
!$omp target update to(cc)
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
! check Fortran pointer after target-value modification
cc = 33333.0_c_double
!$omp target update to(cc)
call copy3_scalar(c_loc(cptr), c_loc(dptr))
!$omp target update from(dd)
if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
!$omp end target data
if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) call abort()
!$omp target data map(to:ee) map(from:ff)
!$omp target data map(alloc:dummy) use_device_addr(ee,ff)
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (.not.associated(ee) .or. .not.associated(ff)) call abort()
if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
c_eptr = c_loc(ee)
c_fptr = c_loc(ff)
eptr => ee
fptr => ff
if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) call abort()
if (.not.associated(eptr) .or. .not.associated(fptr)) call abort()
!$omp end target data
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (.not.associated(ee) .or. .not.associated(ff)) call abort()
if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) call abort()
if (.not.associated(eptr) .or. .not.associated(fptr)) call abort()
! check c_loc ptr once
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
! check c_loc ptr again after target-value modification
ee = 5555.0_c_double
!$omp target update to(ee)
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
! check Fortran pointer after target-value modification
ee = 55555.0_c_double
!$omp target update to(ee)
call copy3_scalar(c_loc(eptr), c_loc(fptr))
!$omp target update from(ff)
if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) call abort()
!$omp end target data
if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh)
!$omp target data map(alloc:dummy) use_device_addr(gg,hh)
if (.not.present(gg) .or. .not.present(hh)) call abort()
if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
c_gptr = c_loc(gg)
c_hptr = c_loc(hh)
gptr => gg
hptr => hh
if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) call abort()
if (.not.associated(gptr) .or. .not.associated(hptr)) call abort()
!$omp end target data
if (.not.present(gg) .or. .not.present(hh)) call abort()
if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) call abort()
if (.not.associated(gptr) .or. .not.associated(hptr)) call abort()
! check c_loc ptr once
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) call abort()
! check c_loc ptr again after target-value modification
gg = 7777.0_c_double
!$omp target update to(gg)
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 7777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
! check Fortran pointer after target-value modification
gg = 77777.0_c_double
!$omp target update to(gg)
call copy3_array(c_loc(gptr), c_loc(hptr), N)
!$omp target update from(hh)
if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
!$omp end target data
if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
end subroutine test_dummy_opt_callee_2
end module test_dummies_opt
! Test local dummy arguments + OPTIONAL + VALUE
! Values present
module test_dummies_opt_value
use iso_c_binding
use target_procs
implicit none
private
public :: test_dummy_opt_val_call_1, test_dummy_opt_val_call_2
contains
subroutine test_dummy_opt_val_call_1()
! scalars - with value, neither allocatable nor pointer no dimension permitted
real(c_double), target :: aa, bb
aa = 11.0_c_double
bb = 22.0_c_double
call test_dummy_opt_val_callee_1(aa, bb)
end subroutine test_dummy_opt_val_call_1
subroutine test_dummy_opt_val_callee_1(aa, bb)
! scalars
real(c_double), optional, value, target :: aa, bb
if (.not.present(aa) .or. .not.present(bb)) call abort()
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
call copy3_scalar(c_loc(aa), c_loc(bb))
!$omp end target data
if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
end subroutine test_dummy_opt_val_callee_1
! Save device ptr - and recall pointer
subroutine test_dummy_opt_val_call_2()
! scalars - with value, neither allocatable nor pointer no dimension permitted
real(c_double), target :: aa, bb
type(c_ptr) :: c_aptr, c_bptr
real(c_double), pointer :: aptr, bptr
call test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
end subroutine test_dummy_opt_val_call_2
subroutine test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
real(c_double), optional, value, target :: aa, bb
type(c_ptr), optional, value :: c_aptr, c_bptr
real(c_double), optional, pointer :: aptr, bptr
real(c_double) :: dummy
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
if (.not.present(aptr) .or. .not.present(bptr)) call abort()
aa = 111.0_c_double
bb = 222.0_c_double
!$omp target data map(to:aa) map(from:bb)
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
if (.not.present(aptr) .or. .not.present(bptr)) call abort()
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
if (.not.present(aptr) .or. .not.present(bptr)) call abort()
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
! check c_loc ptr again after target-value modification
aa = 1111.0_c_double
!$omp target update to(aa)
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
! check Fortran pointer after target-value modification
aa = 11111.0_c_double
!$omp target update to(aa)
call copy3_scalar(c_loc(aptr), c_loc(bptr))
!$omp target update from(bb)
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp end target data
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
end subroutine test_dummy_opt_val_callee_2
end module test_dummies_opt_value
! Test nullptr
module test_nullptr
use iso_c_binding
implicit none
private
public :: test_nullptr_1
contains
subroutine test_nullptr_1()
! scalars
real(c_double), pointer :: aa, bb
real(c_double), pointer :: ee, ff
type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr
real(c_double), pointer :: aptr, bptr, eptr, fptr
aa => null()
bb => null()
ee => null()
ff => null()
if (associated(aa) .or. associated(bb)) call abort()
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
if (c_associated(c_loc(aa)) .or. c_associated(c_loc(bb))) call abort()
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
if (c_associated(c_aptr) .or. c_associated(c_bptr)) call abort()
if (associated(aptr) .or. associated(bptr, bb)) call abort()
!$omp end target data
if (c_associated(c_aptr) .or. c_associated(c_bptr)) call abort()
if (associated(aptr) .or. associated(bptr, bb)) call abort()
call test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
end subroutine test_nullptr_1
subroutine test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
! scalars
real(c_double), optional, pointer :: ee, ff
type(c_ptr), optional :: c_eptr, c_fptr
real(c_double), optional, pointer :: eptr, fptr
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (associated(ee) .or. associated(ff)) call abort()
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (associated(ee) .or. associated(ff)) call abort()
if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) call abort()
c_eptr = c_loc(ee)
c_fptr = c_loc(ff)
eptr => ee
fptr => ff
if (c_associated(c_eptr) .or. c_associated(c_fptr)) call abort()
if (associated(eptr) .or. associated(fptr)) call abort()
!$omp end target data
if (c_associated(c_eptr) .or. c_associated(c_fptr)) call abort()
if (associated(eptr) .or. associated(fptr)) call abort()
end subroutine test_dummy_opt_nullptr_callee_1
end module test_nullptr
! Test local variables
module tests
use iso_c_binding
use target_procs
implicit none
private
public :: test_main_1, test_main_2
contains
! map + use_device_addr + c_loc
subroutine test_main_1()
integer, parameter :: N = 1000
! scalars
real(c_double), target :: aa, bb
real(c_double), target, allocatable :: cc, dd
real(c_double), pointer :: ee, ff
! non-descriptor arrays
real(c_double), target :: gg(N), hh(N)
allocate(cc, dd, ee, ff)
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
gg = 77.0_c_double
hh = 88.0_c_double
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
call copy3_scalar(c_loc(aa), c_loc(bb))
!$omp end target data
if (abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
call copy3_scalar(c_loc(cc), c_loc(dd))
!$omp end target data
if (abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
call copy3_scalar(c_loc(ee), c_loc(ff))
!$omp end target data
if (abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
call copy3_array(c_loc(gg), c_loc(hh), N)
!$omp end target data
if (any(abs(gg - 77.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
deallocate(ee, ff) ! pointers, only
end subroutine test_main_1
! Save device ptr - and recall pointer
subroutine test_main_2
integer, parameter :: N = 1000
! scalars
real(c_double), target :: aa, bb
real(c_double), target, allocatable :: cc, dd
real(c_double), pointer :: ee, ff
! non-descriptor arrays
real(c_double), target :: gg(N), hh(N)
real(c_double) :: dummy
type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
real(c_double), pointer :: gptr(:), hptr(:)
allocate(cc, dd, ee, ff)
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
gg = 777.0_c_double
hh = 888.0_c_double
!$omp target data map(to:aa) map(from:bb)
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
! check c_loc ptr again after target-value modification
aa = 1111.0_c_double
!$omp target update to(aa)
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
! check Fortran pointer after target-value modification
aa = 11111.0_c_double
!$omp target update to(aa)
call copy3_scalar(c_loc(aptr), c_loc(bptr))
!$omp target update from(bb)
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp end target data
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) call abort()
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd)
!$omp target data map(alloc:dummy) use_device_addr(cc,dd)
c_cptr = c_loc(cc)
c_dptr = c_loc(dd)
cptr => cc
dptr => dd
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
! check c_loc ptr again after target-value modification
cc = 3333.0_c_double
!$omp target update to(cc)
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
! check Fortran pointer after target-value modification
cc = 33333.0_c_double
!$omp target update to(cc)
call copy3_scalar(c_loc(cptr), c_loc(dptr))
!$omp target update from(dd)
if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) call abort()
!$omp end target data
if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) call abort()
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) call abort()
!$omp target data map(to:ee) map(from:ff)
!$omp target data map(alloc:dummy) use_device_addr(ee,ff)
c_eptr = c_loc(ee)
c_fptr = c_loc(ff)
eptr => ee
fptr => ff
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
! check c_loc ptr again after target-value modification
ee = 5555.0_c_double
!$omp target update to(ee)
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
! check Fortran pointer after target-value modification
ee = 55555.0_c_double
!$omp target update to(ee)
call copy3_scalar(c_loc(eptr), c_loc(fptr))
!$omp target update from(ff)
if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) call abort()
!$omp end target data
if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) call abort()
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh)
!$omp target data map(alloc:dummy) use_device_addr(gg,hh)
c_gptr = c_loc(gg)
c_hptr = c_loc(hh)
gptr => gg
hptr => hh
!$omp end target data
! check c_loc ptr once
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) call abort()
! check c_loc ptr again after target-value modification
gg = 7777.0_c_double
!$omp target update to(gg)
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 7777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
! check Fortran pointer after target-value modification
gg = 77777.0_c_double
!$omp target update to(gg)
call copy3_array(c_loc(gptr), c_loc(hptr), N)
!$omp target update from(hh)
if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
!$omp end target data
if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) call abort()
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) call abort()
deallocate(ee, ff)
end subroutine test_main_2
end module tests
program omp_device_addr
use tests
use test_dummies
use test_dummies_value
use test_dummies_opt
use test_dummies_opt_value
use test_nullptr
implicit none
call test_main_1()
call test_main_2()
call test_dummy_call_1()
call test_dummy_call_2()
call test_dummy_val_call_1()
call test_dummy_val_call_2()
call test_dummy_opt_call_1()
call test_dummy_opt_call_2()
call test_dummy_opt_val_call_1()
call test_dummy_opt_val_call_2()
call test_nullptr_1()
end program omp_device_addr
[-- Attachment #3: use_device_addr-2.f90 --]
[-- Type: text/x-fortran, Size: 44540 bytes --]
! Comprehensive run-time test for use_device_addr
!
! Differs from use_device_addr-1.f90 by using a 4-byte variable (c_float)
!
! This test case assumes that a 'var' appearing in 'use_device_addr' is
! only used as 'c_loc(var)' - such that only the actual data is used/usable
! on the device - and not meta data ((dynamic) type information, 'present()'
! status, array shape).
!
! Untested in this test case are:
! - arrays with array descriptor
! - polymorphic variables
! - absent optional arguments
!
module target_procs
use iso_c_binding
implicit none
private
public :: copy3_array, copy3_scalar
contains
subroutine copy3_array_int(from_ptr, to_ptr, N)
!$omp declare target
real(c_float) :: from_ptr(:)
real(c_float) :: 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_float) :: 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_float), 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_float), 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_float), 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_float), 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
end module target_procs
! Test local dummy arguments (w/o optional)
module test_dummies
use iso_c_binding
use target_procs
implicit none
private
public :: test_dummy_call_1, test_dummy_call_2
contains
subroutine test_dummy_call_1()
integer, parameter :: N = 1000
! scalars
real(c_float), target :: aa, bb
real(c_float), target, allocatable :: cc, dd
real(c_float), pointer :: ee, ff
! non-descriptor arrays
real(c_float), target :: gg(N), hh(N)
allocate(cc, dd, ee, ff)
aa = 11.0_c_float
bb = 22.0_c_float
cc = 33.0_c_float
dd = 44.0_c_float
ee = 55.0_c_float
ff = 66.0_c_float
gg = 77.0_c_float
hh = 88.0_c_float
call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
deallocate(ee, ff) ! pointers, only
end subroutine test_dummy_call_1
subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
! scalars
real(c_float), target :: aa, bb
real(c_float), target, allocatable :: cc, dd
real(c_float), pointer :: ee, ff
! non-descriptor arrays
real(c_float), target :: gg(N), hh(N)
integer, value :: N
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
call copy3_scalar(c_loc(aa), c_loc(bb))
!$omp end target data
if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
call copy3_scalar(c_loc(cc), c_loc(dd))
!$omp end target data
if (abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
call copy3_scalar(c_loc(ee), c_loc(ff))
!$omp end target data
if (abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
call copy3_array(c_loc(gg), c_loc(hh), N)
!$omp end target data
if (any(abs(gg - 77.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
end subroutine test_dummy_callee_1
! Save device ptr - and recall pointer
subroutine test_dummy_call_2()
integer, parameter :: N = 1000
! scalars
real(c_float), target :: aa, bb
real(c_float), target, allocatable :: cc, dd
real(c_float), pointer :: ee, ff
! non-descriptor arrays
real(c_float), target :: gg(N), hh(N)
type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
real(c_float), pointer :: gptr(:), hptr(:)
allocate(cc, dd, ee, ff)
call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
N)
deallocate(ee, ff)
end subroutine test_dummy_call_2
subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
N)
! scalars
real(c_float), target :: aa, bb
real(c_float), target, allocatable :: cc, dd
real(c_float), pointer :: ee, ff
! non-descriptor arrays
real(c_float), target :: gg(N), hh(N)
type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
real(c_float), pointer :: gptr(:), hptr(:)
integer, value :: N
real(c_float) :: dummy
aa = 111.0_c_float
bb = 222.0_c_float
cc = 333.0_c_float
dd = 444.0_c_float
ee = 555.0_c_float
ff = 666.0_c_float
gg = 777.0_c_float
hh = 888.0_c_float
!$omp target data map(to:aa) map(from:bb)
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
! check c_loc ptr again after target-value modification
aa = 1111.0_c_float
!$omp target update to(aa)
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
! check Fortran pointer after target-value modification
aa = 11111.0_c_float
!$omp target update to(aa)
call copy3_scalar(c_loc(aptr), c_loc(bptr))
!$omp target update from(bb)
if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp end target data
if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd)
!$omp target data map(alloc:dummy) use_device_addr(cc,dd)
c_cptr = c_loc(cc)
c_dptr = c_loc(dd)
cptr => cc
dptr => dd
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
! check c_loc ptr again after target-value modification
cc = 3333.0_c_float
!$omp target update to(cc)
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
! check Fortran pointer after target-value modification
cc = 33333.0_c_float
!$omp target update to(cc)
call copy3_scalar(c_loc(cptr), c_loc(dptr))
!$omp target update from(dd)
if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
!$omp end target data
if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd)) call abort()
!$omp target data map(to:ee) map(from:ff)
!$omp target data map(alloc:dummy) use_device_addr(ee,ff)
c_eptr = c_loc(ee)
c_fptr = c_loc(ff)
eptr => ee
fptr => ff
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
! check c_loc ptr again after target-value modification
ee = 5555.0_c_float
!$omp target update to(ee)
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
! check Fortran pointer after target-value modification
ee = 55555.0_c_float
!$omp target update to(ee)
call copy3_scalar(c_loc(eptr), c_loc(fptr))
!$omp target update from(ff)
if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff)) call abort()
!$omp end target data
if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh)
!$omp target data map(alloc:dummy) use_device_addr(gg,hh)
c_gptr = c_loc(gg)
c_hptr = c_loc(hh)
gptr => gg
hptr => hh
!$omp end target data
! check c_loc ptr once
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(hh))) call abort()
! check c_loc ptr again after target-value modification
gg = 7777.0_c_float
!$omp target update to(gg)
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 7777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
! check Fortran pointer after target-value modification
gg = 77777.0_c_float
!$omp target update to(gg)
call copy3_array(c_loc(gptr), c_loc(hptr), N)
!$omp target update from(hh)
if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
!$omp end target data
if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
end subroutine test_dummy_callee_2
end module test_dummies
! Test local dummy arguments + VALUE (w/o optional)
module test_dummies_value
use iso_c_binding
use target_procs
implicit none
private
public :: test_dummy_val_call_1, test_dummy_val_call_2
contains
subroutine test_dummy_val_call_1()
! scalars - with value, neither allocatable nor pointer no dimension permitted
real(c_float), target :: aa, bb
aa = 11.0_c_float
bb = 22.0_c_float
call test_dummy_val_callee_1(aa, bb)
end subroutine test_dummy_val_call_1
subroutine test_dummy_val_callee_1(aa, bb)
! scalars
real(c_float), value, target :: aa, bb
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
call copy3_scalar(c_loc(aa), c_loc(bb))
!$omp end target data
if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
end subroutine test_dummy_val_callee_1
! Save device ptr - and recall pointer
subroutine test_dummy_val_call_2()
! scalars - with value, neither allocatable nor pointer no dimension permitted
real(c_float), target :: aa, bb
type(c_ptr) :: c_aptr, c_bptr
real(c_float), pointer :: aptr, bptr
call test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
end subroutine test_dummy_val_call_2
subroutine test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
real(c_float), value, target :: aa, bb
type(c_ptr), value :: c_aptr, c_bptr
real(c_float), pointer :: aptr, bptr
real(c_float) :: dummy
aa = 111.0_c_float
bb = 222.0_c_float
!$omp target data map(to:aa) map(from:bb)
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
! check c_loc ptr again after target-value modification
aa = 1111.0_c_float
!$omp target update to(aa)
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
! check Fortran pointer after target-value modification
aa = 11111.0_c_float
!$omp target update to(aa)
call copy3_scalar(c_loc(aptr), c_loc(bptr))
!$omp target update from(bb)
if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp end target data
if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
end subroutine test_dummy_val_callee_2
end module test_dummies_value
! Test local dummy arguments + OPTIONAL
! Values present and ptr associated to nonzero
module test_dummies_opt
use iso_c_binding
use target_procs
implicit none
private
public :: test_dummy_opt_call_1, test_dummy_opt_call_2
contains
subroutine test_dummy_opt_call_1()
integer, parameter :: N = 1000
! scalars
real(c_float), target :: aa, bb
real(c_float), target, allocatable :: cc, dd
real(c_float), pointer :: ee, ff
! non-descriptor arrays
real(c_float), target :: gg(N), hh(N)
allocate(cc, dd, ee, ff)
aa = 11.0_c_float
bb = 22.0_c_float
cc = 33.0_c_float
dd = 44.0_c_float
ee = 55.0_c_float
ff = 66.0_c_float
gg = 77.0_c_float
hh = 88.0_c_float
call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
deallocate(ee, ff) ! pointers, only
end subroutine test_dummy_opt_call_1
subroutine test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
! scalars
real(c_float), optional, target :: aa, bb
real(c_float), optional, target, allocatable :: cc, dd
real(c_float), optional, pointer :: ee, ff
! non-descriptor arrays
real(c_float), optional, target :: gg(N), hh(N)
integer, value :: N
! All shall be present - and pointing to non-NULL
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.present(cc) .or. .not.present(dd)) call abort()
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (.not.present(gg) .or. .not.present(hh)) call abort()
if (.not.associated(ee) .or. .not.associated(ff)) call abort()
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
call copy3_scalar(c_loc(aa), c_loc(bb))
!$omp end target data
if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
if (.not.present(cc) .or. .not.present(dd)) call abort()
if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
call copy3_scalar(c_loc(cc), c_loc(dd))
!$omp end target data
if (abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (.not.associated(ee) .or. .not.associated(ff)) call abort()
if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
call copy3_scalar(c_loc(ee), c_loc(ff))
!$omp end target data
if (abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
if (.not.present(gg) .or. .not.present(hh)) call abort()
if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
call copy3_array(c_loc(gg), c_loc(hh), N)
!$omp end target data
if (any(abs(gg - 77.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
end subroutine test_dummy_opt_callee_1
! Save device ptr - and recall pointer
subroutine test_dummy_opt_call_2()
integer, parameter :: N = 1000
! scalars
real(c_float), target :: aa, bb
real(c_float), target, allocatable :: cc, dd
real(c_float), pointer :: ee, ff
! non-descriptor arrays
real(c_float), target :: gg(N), hh(N)
type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
real(c_float), pointer :: gptr(:), hptr(:)
allocate(cc, dd, ee, ff)
call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
N)
deallocate(ee, ff)
end subroutine test_dummy_opt_call_2
subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
N)
! scalars
real(c_float), optional, target :: aa, bb
real(c_float), optional, target, allocatable :: cc, dd
real(c_float), optional, pointer :: ee, ff
! non-descriptor arrays
real(c_float), optional, target :: gg(N), hh(N)
type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
real(c_float), optional, pointer :: aptr, bptr, cptr, dptr, eptr, fptr
real(c_float), optional, pointer :: gptr(:), hptr(:)
integer, value :: N
real(c_float) :: dummy
! All shall be present - and pointing to non-NULL
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.present(cc) .or. .not.present(dd)) call abort()
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (.not.present(gg) .or. .not.present(hh)) call abort()
if (.not.associated(ee) .or. .not.associated(ff)) call abort()
aa = 111.0_c_float
bb = 222.0_c_float
cc = 333.0_c_float
dd = 444.0_c_float
ee = 555.0_c_float
ff = 666.0_c_float
gg = 777.0_c_float
hh = 888.0_c_float
!$omp target data map(to:aa) map(from:bb)
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
!$omp end target data
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
! check c_loc ptr once
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
! check c_loc ptr again after target-value modification
aa = 1111.0_c_float
!$omp target update to(aa)
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
! check Fortran pointer after target-value modification
aa = 11111.0_c_float
!$omp target update to(aa)
call copy3_scalar(c_loc(aptr), c_loc(bptr))
!$omp target update from(bb)
if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp end target data
if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd)
!$omp target data map(alloc:dummy) use_device_addr(cc,dd)
if (.not.present(cc) .or. .not.present(dd)) call abort()
if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
c_cptr = c_loc(cc)
c_dptr = c_loc(dd)
cptr => cc
dptr => dd
if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) call abort()
if (.not.associated(cptr) .or. .not.associated(dptr)) call abort()
!$omp end target data
if (.not.present(cc) .or. .not.present(dd)) call abort()
if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) call abort()
if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) call abort()
if (.not.associated(cptr) .or. .not.associated(dptr)) call abort()
! check c_loc ptr once
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
! check c_loc ptr again after target-value modification
cc = 3333.0_c_float
!$omp target update to(cc)
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
! check Fortran pointer after target-value modification
cc = 33333.0_c_float
!$omp target update to(cc)
call copy3_scalar(c_loc(cptr), c_loc(dptr))
!$omp target update from(dd)
if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
!$omp end target data
if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd)) call abort()
!$omp target data map(to:ee) map(from:ff)
!$omp target data map(alloc:dummy) use_device_addr(ee,ff)
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (.not.associated(ee) .or. .not.associated(ff)) call abort()
if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
c_eptr = c_loc(ee)
c_fptr = c_loc(ff)
eptr => ee
fptr => ff
if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) call abort()
if (.not.associated(eptr) .or. .not.associated(fptr)) call abort()
!$omp end target data
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (.not.associated(ee) .or. .not.associated(ff)) call abort()
if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) call abort()
if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) call abort()
if (.not.associated(eptr) .or. .not.associated(fptr)) call abort()
! check c_loc ptr once
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
! check c_loc ptr again after target-value modification
ee = 5555.0_c_float
!$omp target update to(ee)
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
! check Fortran pointer after target-value modification
ee = 55555.0_c_float
!$omp target update to(ee)
call copy3_scalar(c_loc(eptr), c_loc(fptr))
!$omp target update from(ff)
if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff)) call abort()
!$omp end target data
if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh)
!$omp target data map(alloc:dummy) use_device_addr(gg,hh)
if (.not.present(gg) .or. .not.present(hh)) call abort()
if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
c_gptr = c_loc(gg)
c_hptr = c_loc(hh)
gptr => gg
hptr => hh
if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) call abort()
if (.not.associated(gptr) .or. .not.associated(hptr)) call abort()
!$omp end target data
if (.not.present(gg) .or. .not.present(hh)) call abort()
if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) call abort()
if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) call abort()
if (.not.associated(gptr) .or. .not.associated(hptr)) call abort()
! check c_loc ptr once
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(hh))) call abort()
! check c_loc ptr again after target-value modification
gg = 7777.0_c_float
!$omp target update to(gg)
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 7777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
! check Fortran pointer after target-value modification
gg = 77777.0_c_float
!$omp target update to(gg)
call copy3_array(c_loc(gptr), c_loc(hptr), N)
!$omp target update from(hh)
if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
!$omp end target data
if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
end subroutine test_dummy_opt_callee_2
end module test_dummies_opt
! Test local dummy arguments + OPTIONAL + VALUE
! Values present
module test_dummies_opt_value
use iso_c_binding
use target_procs
implicit none
private
public :: test_dummy_opt_val_call_1, test_dummy_opt_val_call_2
contains
subroutine test_dummy_opt_val_call_1()
! scalars - with value, neither allocatable nor pointer no dimension permitted
real(c_float), target :: aa, bb
aa = 11.0_c_float
bb = 22.0_c_float
call test_dummy_opt_val_callee_1(aa, bb)
end subroutine test_dummy_opt_val_call_1
subroutine test_dummy_opt_val_callee_1(aa, bb)
! scalars
real(c_float), optional, value, target :: aa, bb
if (.not.present(aa) .or. .not.present(bb)) call abort()
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) call abort()
call copy3_scalar(c_loc(aa), c_loc(bb))
!$omp end target data
if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
end subroutine test_dummy_opt_val_callee_1
! Save device ptr - and recall pointer
subroutine test_dummy_opt_val_call_2()
! scalars - with value, neither allocatable nor pointer no dimension permitted
real(c_float), target :: aa, bb
type(c_ptr) :: c_aptr, c_bptr
real(c_float), pointer :: aptr, bptr
call test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
end subroutine test_dummy_opt_val_call_2
subroutine test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
real(c_float), optional, value, target :: aa, bb
type(c_ptr), optional, value :: c_aptr, c_bptr
real(c_float), optional, pointer :: aptr, bptr
real(c_float) :: dummy
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
if (.not.present(aptr) .or. .not.present(bptr)) call abort()
aa = 111.0_c_float
bb = 222.0_c_float
!$omp target data map(to:aa) map(from:bb)
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
if (.not.present(aptr) .or. .not.present(bptr)) call abort()
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
if (.not.present(aa) .or. .not.present(bb)) call abort()
if (.not.present(c_aptr) .or. .not.present(c_bptr)) call abort()
if (.not.present(aptr) .or. .not.present(bptr)) call abort()
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) call abort()
if (.not.associated(aptr) .or. .not.associated(bptr)) call abort()
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
! check c_loc ptr again after target-value modification
aa = 1111.0_c_float
!$omp target update to(aa)
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
! check Fortran pointer after target-value modification
aa = 11111.0_c_float
!$omp target update to(aa)
call copy3_scalar(c_loc(aptr), c_loc(bptr))
!$omp target update from(bb)
if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp end target data
if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
end subroutine test_dummy_opt_val_callee_2
end module test_dummies_opt_value
! Test nullptr
module test_nullptr
use iso_c_binding
implicit none
private
public :: test_nullptr_1
contains
subroutine test_nullptr_1()
! scalars
real(c_float), pointer :: aa, bb
real(c_float), pointer :: ee, ff
type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr
real(c_float), pointer :: aptr, bptr, eptr, fptr
aa => null()
bb => null()
ee => null()
ff => null()
if (associated(aa) .or. associated(bb)) call abort()
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
if (c_associated(c_loc(aa)) .or. c_associated(c_loc(bb))) call abort()
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
if (c_associated(c_aptr) .or. c_associated(c_bptr)) call abort()
if (associated(aptr) .or. associated(bptr, bb)) call abort()
!$omp end target data
if (c_associated(c_aptr) .or. c_associated(c_bptr)) call abort()
if (associated(aptr) .or. associated(bptr, bb)) call abort()
call test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
end subroutine test_nullptr_1
subroutine test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
! scalars
real(c_float), optional, pointer :: ee, ff
type(c_ptr), optional :: c_eptr, c_fptr
real(c_float), optional, pointer :: eptr, fptr
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (associated(ee) .or. associated(ff)) call abort()
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
if (.not.present(ee) .or. .not.present(ff)) call abort()
if (associated(ee) .or. associated(ff)) call abort()
if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) call abort()
c_eptr = c_loc(ee)
c_fptr = c_loc(ff)
eptr => ee
fptr => ff
if (c_associated(c_eptr) .or. c_associated(c_fptr)) call abort()
if (associated(eptr) .or. associated(fptr)) call abort()
!$omp end target data
if (c_associated(c_eptr) .or. c_associated(c_fptr)) call abort()
if (associated(eptr) .or. associated(fptr)) call abort()
end subroutine test_dummy_opt_nullptr_callee_1
end module test_nullptr
! Test local variables
module tests
use iso_c_binding
use target_procs
implicit none
private
public :: test_main_1, test_main_2
contains
! map + use_device_addr + c_loc
subroutine test_main_1()
integer, parameter :: N = 1000
! scalars
real(c_float), target :: aa, bb
real(c_float), target, allocatable :: cc, dd
real(c_float), pointer :: ee, ff
! non-descriptor arrays
real(c_float), target :: gg(N), hh(N)
allocate(cc, dd, ee, ff)
aa = 11.0_c_float
bb = 22.0_c_float
cc = 33.0_c_float
dd = 44.0_c_float
ee = 55.0_c_float
ff = 66.0_c_float
gg = 77.0_c_float
hh = 88.0_c_float
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
call copy3_scalar(c_loc(aa), c_loc(bb))
!$omp end target data
if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
call copy3_scalar(c_loc(cc), c_loc(dd))
!$omp end target data
if (abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
call copy3_scalar(c_loc(ee), c_loc(ff))
!$omp end target data
if (abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
call copy3_array(c_loc(gg), c_loc(hh), N)
!$omp end target data
if (any(abs(gg - 77.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
deallocate(ee, ff) ! pointers, only
end subroutine test_main_1
! Save device ptr - and recall pointer
subroutine test_main_2
integer, parameter :: N = 1000
! scalars
real(c_float), target :: aa, bb
real(c_float), target, allocatable :: cc, dd
real(c_float), pointer :: ee, ff
! non-descriptor arrays
real(c_float), target :: gg(N), hh(N)
real(c_float) :: dummy
type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
real(c_float), pointer :: gptr(:), hptr(:)
allocate(cc, dd, ee, ff)
aa = 111.0_c_float
bb = 222.0_c_float
cc = 333.0_c_float
dd = 444.0_c_float
ee = 555.0_c_float
ff = 666.0_c_float
gg = 777.0_c_float
hh = 888.0_c_float
!$omp target data map(to:aa) map(from:bb)
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
c_aptr = c_loc(aa)
c_bptr = c_loc(bb)
aptr => aa
bptr => bb
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
! check c_loc ptr again after target-value modification
aa = 1111.0_c_float
!$omp target update to(aa)
call copy3_scalar(c_aptr, c_bptr)
!$omp target update from(bb)
if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
! check Fortran pointer after target-value modification
aa = 11111.0_c_float
!$omp target update to(aa)
call copy3_scalar(c_loc(aptr), c_loc(bptr))
!$omp target update from(bb)
if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp end target data
if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) call abort()
if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) call abort()
!$omp target data map(to:cc) map(from:dd)
!$omp target data map(alloc:dummy) use_device_addr(cc,dd)
c_cptr = c_loc(cc)
c_dptr = c_loc(dd)
cptr => cc
dptr => dd
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
! check c_loc ptr again after target-value modification
cc = 3333.0_c_float
!$omp target update to(cc)
call copy3_scalar(c_cptr, c_dptr)
!$omp target update from(dd)
if (abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
! check Fortran pointer after target-value modification
cc = 33333.0_c_float
!$omp target update to(cc)
call copy3_scalar(c_loc(cptr), c_loc(dptr))
!$omp target update from(dd)
if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) call abort()
!$omp end target data
if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd)) call abort()
if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd)) call abort()
!$omp target data map(to:ee) map(from:ff)
!$omp target data map(alloc:dummy) use_device_addr(ee,ff)
c_eptr = c_loc(ee)
c_fptr = c_loc(ff)
eptr => ee
fptr => ff
!$omp end target data
! check c_loc ptr once
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
! check c_loc ptr again after target-value modification
ee = 5555.0_c_float
!$omp target update to(ee)
call copy3_scalar(c_eptr, c_fptr)
!$omp target update from(ff)
if (abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
! check Fortran pointer after target-value modification
ee = 55555.0_c_float
!$omp target update to(ee)
call copy3_scalar(c_loc(eptr), c_loc(fptr))
!$omp target update from(ff)
if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff)) call abort()
!$omp end target data
if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) call abort()
if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) call abort()
!$omp target data map(to:gg) map(from:hh)
!$omp target data map(alloc:dummy) use_device_addr(gg,hh)
c_gptr = c_loc(gg)
c_hptr = c_loc(hh)
gptr => gg
hptr => hh
!$omp end target data
! check c_loc ptr once
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(hh))) call abort()
! check c_loc ptr again after target-value modification
gg = 7777.0_c_float
!$omp target update to(gg)
call copy3_array(c_gptr, c_hptr, N)
!$omp target update from(hh)
if (any(abs(gg - 7777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
! check Fortran pointer after target-value modification
gg = 77777.0_c_float
!$omp target update to(gg)
call copy3_array(c_loc(gptr), c_loc(hptr), N)
!$omp target update from(hh)
if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
!$omp end target data
if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) call abort()
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) call abort()
deallocate(ee, ff)
end subroutine test_main_2
end module tests
program omp_device_addr
use tests
use test_dummies
use test_dummies_value
use test_dummies_opt
use test_dummies_opt_value
use test_nullptr
implicit none
call test_main_1()
call test_main_2()
call test_dummy_call_1()
call test_dummy_call_2()
call test_dummy_val_call_1()
call test_dummy_val_call_2()
call test_dummy_opt_call_1()
call test_dummy_opt_call_2()
call test_dummy_opt_val_call_1()
call test_dummy_opt_val_call_2()
call test_nullptr_1()
end program omp_device_addr
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: [patch][OpenMP,Fortran] Fix several OpenMP use_device_addr/map/update errors found by a length test case
2019-10-10 16:53 ` Tobias Burnus
@ 2019-10-10 16:55 ` Jakub Jelinek
2019-10-10 17:06 ` Janne Blomqvist
1 sibling, 0 replies; 6+ messages in thread
From: Jakub Jelinek @ 2019-10-10 16:55 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc-patches, fortran
On Thu, Oct 10, 2019 at 06:49:52PM +0200, Tobias Burnus wrote:
> On 10/10/19 1:55 PM, Jakub Jelinek wrote:
> > What worries me about the test is that the officially only portable way
> > to use it in a target region is is_device_ptr.
>
> How about the attached test cases? The only difference is in "module
> target_procs".
>
> OK now?
Ok then. If is_device_ptr is clarified/the restriction lifted, we can
always change it.
Jakub
^ permalink raw reply [flat|nested] 6+ messages in thread
* Re: [patch][OpenMP,Fortran] Fix several OpenMP use_device_addr/map/update errors found by a length test case
2019-10-10 16:53 ` Tobias Burnus
2019-10-10 16:55 ` Jakub Jelinek
@ 2019-10-10 17:06 ` Janne Blomqvist
1 sibling, 0 replies; 6+ messages in thread
From: Janne Blomqvist @ 2019-10-10 17:06 UTC (permalink / raw)
To: Tobias Burnus; +Cc: Jakub Jelinek, gcc-patches, fortran
On Thu, Oct 10, 2019 at 7:50 PM Tobias Burnus <tobias@codesourcery.com> wrote:
>
> Hi Jakub,
>
> On 10/10/19 1:55 PM, Jakub Jelinek wrote:
> > What worries me about the test is that the officially only portable way
> > to use it in a target region is is_device_ptr.
>
> How about the attached test cases? The only difference is in "module
> target_procs".
As previously mentioned, please use "stop N" instead of "call abort()".
--
Janne Blomqvist
^ permalink raw reply [flat|nested] 6+ messages in thread
end of thread, other threads:[~2019-10-10 16:55 UTC | newest]
Thread overview: 6+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2019-10-04 13:54 [patch][OpenMP,Fortran] Fix trans-openmp.c, add use_device_addr run-time test case (has known issues with actual offloading) Tobias Burnus
2019-10-07 23:12 ` [patch][OpenMP,Fortran] Fix several OpenMP use_device_addr/map/update errors found by a length test case Tobias Burnus
2019-10-10 12:22 ` Jakub Jelinek
2019-10-10 16:53 ` Tobias Burnus
2019-10-10 16:55 ` Jakub Jelinek
2019-10-10 17:06 ` Janne Blomqvist
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).