mirror of
https://forge.sourceware.org/marek/gcc.git
synced 2026-02-22 03:47:02 -05:00
a57b0e3ecb
Bumps OpenMP from 4.5 (201511) to 5.2 (202111), with deprecation and
test support to 5.1 (202011). Adds new tests and a new warning.
Suppresses deprecation warnings in all relevant tests and removes
suppression pragmas visible outside of the testsuite. Additionally
implements new warning in the relevant frontends. Otherwise, cleans
up some whitespace and fixed a misspelled pragma in a testcase. Also
fixes an indentation error.
gcc/c-family/ChangeLog:
* c-cppbuiltin.cc (c_cpp_builtins): Bump _OPENMP version.
* c.opt (Wdeprecated-openmp): Add warning.
* c.opt.urls: Regenerated.
gcc/c/ChangeLog:
* c-parser.cc (c_parser_omp_clause_proc_bind): Deprecate master
affinity.
(c_parser_omp_master): Deprecate master construct.
(c_parser_transaction): Whitespace.
gcc/cp/ChangeLog:
* parser.cc (cp_parser_postfix_expression): Whitespace.
(cp_parser_builtin_c23_va_start): Ditto.
(cp_parser_omp_clause_proc_bind): Deprecate master affinity.
(cp_parser_omp_master): Deprecate master construct.
gcc/ChangeLog:
* doc/invoke.texi: Update docs for '-Wdeprecated-openmp'.
gcc/fortran/ChangeLog:
* cpp.cc (cpp_define_builtins): Bump _OPENMP version.
* invoke.texi: Update docs for '-Wdeprecated-openmp'.
* lang.opt (Wdeprecated-openmp): Add warning.
* lang.opt.urls: Regenerated.
* openmp.cc (gfc_match_omp_clauses): Deprecate master affinity
policy.
(gfc_match_omp_parallel_master): Deprecate master construct.
(gfc_match_omp_parallel_master_taskloop): Ditto.
(gfc_match_omp_parallel_master_taskloop_simd): Ditto.
(gfc_match_omp_master): Ditto.
(gfc_match_omp_master_taskloop): Ditto.
(gfc_match_omp_master_taskloop_simd): Ditto.
(resolve_omp_clauses): Warn for deprecated use of
{use,is}_device_ptr.
libgomp/ChangeLog:
* env.c (omp_display_env): Bump _OPENMP version.
* fortran.c (ialias_redirect): Remove suppression pragmas.
(omp_set_dynamic_8_): Ditto.
(omp_set_nested_8_): Ditto.
(omp_get_nested_): Ditto.
* icv.c (omp_get_dynamic): Ditto.
(omp_get_nested): Ditto.
(ialias): Ditto.
* omp_lib.f90.in: Bump openmp_version.
* omp_lib.h.in: Ditto.
* testsuite/libgomp.c++/affinity-1.C: Suppress deprecation
warnings.
* testsuite/libgomp.c++/ctor-1.C: Ditto.
* testsuite/libgomp.c++/ctor-11.C: Ditto.
* testsuite/libgomp.c++/ctor-13.C: Ditto.
* testsuite/libgomp.c++/ctor-2.C: Ditto.
* testsuite/libgomp.c++/ctor-5.C: Ditto.
* testsuite/libgomp.c++/ctor-7.C: Ditto.
* testsuite/libgomp.c++/depend-iterator-1.C: Ditto.
* testsuite/libgomp.c++/loop-13.C: Ditto.
* testsuite/libgomp.c++/master-1.C: Ditto.
* testsuite/libgomp.c++/pr26943.C: Ditto.
* testsuite/libgomp.c++/pr81130.C: Ditto.
* testsuite/libgomp.c++/pr81314.C: Ditto.
* testsuite/libgomp.c++/target-in-reduction-1.C: Ditto.
* testsuite/libgomp.c++/target-in-reduction-2.C: Ditto.
* testsuite/libgomp.c++/task-1.C: Ditto.
* testsuite/libgomp.c++/task-2.C: Ditto.
* testsuite/libgomp.c++/task-6.C: Ditto.
* testsuite/libgomp.c++/task-reduction-7.C: Ditto.
* testsuite/libgomp.c++/task-reduction-9.C: Ditto.
* testsuite/libgomp.c++/taskloop-reduction-1.C: Ditto.
* testsuite/libgomp.c-c++-common/cancel-taskgroup-4.c: Ditto.
* testsuite/libgomp.c-c++-common/depend-inoutset-1.c: Ditto.
* testsuite/libgomp.c-c++-common/depend-iterator-1.c: Ditto.
* testsuite/libgomp.c-c++-common/master-combined-1.c: Ditto.
* testsuite/libgomp.c-c++-common/target-in-reduction-1.c: Ditto.
* testsuite/libgomp.c-c++-common/target-in-reduction-2.c: Ditto.
* testsuite/libgomp.c-c++-common/task-detach-12.c: Ditto.
* testsuite/libgomp.c-c++-common/task-reduction-15.c: Ditto.
* testsuite/libgomp.c-c++-common/task-reduction-5.c: Ditto.
* testsuite/libgomp.c-c++-common/task-reduction-6.c: Ditto.
* testsuite/libgomp.c-c++-common/task-reduction-8.c: Ditto.
* testsuite/libgomp.c-c++-common/taskloop-reduction-1.c: Ditto.
* testsuite/libgomp.c-c++-common/taskloop-reduction-3.c: Ditto.
* testsuite/libgomp.c-c++-common/taskloop-reduction-4.c: Ditto.
* testsuite/libgomp.c/affinity-1.c: Remove extraneous dg
instruction and add suppression.
* testsuite/libgomp.c/critical-2.c: Suppress deprecation
warnings.
* testsuite/libgomp.c/debug-1.c: Ditto.
* testsuite/libgomp.c/lib-1.c: Ditto.
* testsuite/libgomp.c/loop-24.c: Ditto.
* testsuite/libgomp.c/nestedfn-2.c: Ditto.
* testsuite/libgomp.c/nestedfn-3.c: Ditto.
* testsuite/libgomp.c/pr104385.c: Ditto.
* testsuite/libgomp.c/target-31.c: Ditto.
* testsuite/libgomp.c/target-34.c: Ditto.
* testsuite/libgomp.c/target-critical-1.c: Ditto.
* testsuite/libgomp.c/task-1.c: Ditto.
* testsuite/libgomp.c/task-3.c: Ditto.
* testsuite/libgomp.c/task-6.c: Ditto.
* testsuite/libgomp.c/task-reduction-1.c: Ditto.
* testsuite/libgomp.c/task-reduction-2.c: Ditto.
* testsuite/libgomp.c/teams-1.c: Ditto.
* testsuite/libgomp.c/vla-1.c: Ditto.
* testsuite/libgomp.fortran/crayptr1.f90: Ditto.
* testsuite/libgomp.fortran/depend-inoutset-1.f90: Ditto.
* testsuite/libgomp.fortran/is_device_ptr-1.f90: Ditto.
* testsuite/libgomp.fortran/is_device_ptr-2.f90: Ditto.
* testsuite/libgomp.fortran/lib1.f90: Ditto.
* testsuite/libgomp.fortran/lib2.f: Ditto.
* testsuite/libgomp.fortran/lib3.f: Ditto.
* testsuite/libgomp.fortran/omp_parse2.f90: Ditto.
* testsuite/libgomp.fortran/openmp_version-1.f: Bump OMP version.
* testsuite/libgomp.fortran/openmp_version-2.f90: Ditto.
* testsuite/libgomp.fortran/parallel-master.f90: Suppress
warnings.
* testsuite/libgomp.fortran/pointer2.f90: Ditto.
* testsuite/libgomp.fortran/reduction6.f90: Ditto.
* testsuite/libgomp.fortran/target-firstprivate-1.f90: Ditto.
* testsuite/libgomp.fortran/use_device_addr-1.f90: Ditto.
* testsuite/libgomp.fortran/use_device_addr-2.f90: Ditto.
* testsuite/libgomp.fortran/use_device_addr-3.f90: Ditto.
* testsuite/libgomp.fortran/use_device_addr-4.f90: Ditto.
* testsuite/libgomp.fortran/use_device_addr-5.f90: Ditto.
* testsuite/libgomp.fortran/use_device_ptr-1.f90: Ditto.
* testsuite/libgomp.fortran/use_device_ptr-3.f90: Ditto.
* testsuite/libgomp.fortran/use_device_ptr-4.f90: Ditto.
* testsuite/libgomp.fortran/use_device_ptr-optional-1.f90: Ditto.
* testsuite/libgomp.fortran/use_device_ptr-optional-2.f90: Ditto.
* testsuite/libgomp.fortran/use_device_ptr-optional-3.f90: Ditto.
* testsuite/libgomp.c-c++-common/omp-atv-seq-dep.c: New test.
* testsuite/libgomp.c-c++-common/omp-lock-hint-contended-dep.c:
New test.
* testsuite/libgomp.c-c++-common/omp-lock-hint-none-dep.c: New test.
* testsuite/libgomp.c-c++-common/omp-lock-hint-speculative-dep.c:
New test.
* testsuite/libgomp.c-c++-common/omp-lock-hint-uncontended-dep.c:
New test.
* testsuite/libgomp.c/omp-proc-bind-master-dep.c: New test.
* testsuite/libgomp.fortran/omp-atv-seq-dep.f90: New test.
* testsuite/libgomp.fortran/omp-lock-hint-contended-dep.f90: New
test.
* testsuite/libgomp.fortran/omp-lock-hint-none-dep.f90: New test.
* testsuite/libgomp.fortran/omp-lock-hint-speculative-dep.f90: New
test.
* testsuite/libgomp.fortran/omp-lock-hint-uncontended-dep.f90: New
test.
gcc/testsuite/ChangeLog:
* c-c++-common/cpp/openmp-define-3.c: Bump OMP version.
* c-c++-common/gomp/Wparentheses-1.c: Suppress deprecation
warnings.
* c-c++-common/gomp/Wparentheses-3.c: Ditto.
* c-c++-common/gomp/affinity-3.c: Ditto.
* c-c++-common/gomp/allocate-18.c: Ditto.
* c-c++-common/gomp/cancel-1.c: Ditto.
* c-c++-common/gomp/clause-dups-1.c: Ditto.
* c-c++-common/gomp/clauses-1.c: Suppress deprecation
warnings and fix misspelled directive. Add
'-Wunknown-pragmas'.
* c-c++-common/gomp/clauses-6.c: Suppress deprecation warnings.
* c-c++-common/gomp/declare-variant-1.c: Ditto.
* c-c++-common/gomp/declare-variant-2.c: Ditto.
* c-c++-common/gomp/depend-iterator-1.c: Ditto.
* c-c++-common/gomp/lastprivate-conditional-1.c: Ditto.
* c-c++-common/gomp/loop-1.c: Ditto.
* c-c++-common/gomp/loop-2.c: Ditto.
* c-c++-common/gomp/loop-3.c: Ditto.
* c-c++-common/gomp/loop-4.c: Ditto.
* c-c++-common/gomp/master-combined-1.c: Ditto.
* c-c++-common/gomp/master-combined-2.c: Ditto.
* c-c++-common/gomp/nesting-2.c: Ditto.
* c-c++-common/gomp/pr100902-1.c: Ditto.
* c-c++-common/gomp/pr61486-2.c: Ditto.
* c-c++-common/gomp/pr85696.c: Ditto.
* c-c++-common/gomp/pr85956.c: Ditto.
* c-c++-common/gomp/pr98187.c: Ditto.
* c-c++-common/gomp/pr99928-1.c: Ditto.
* c-c++-common/gomp/pr99928-10.c: Ditto.
* c-c++-common/gomp/pr99928-11.c: Ditto.
* c-c++-common/gomp/pr99928-12.c: Ditto.
* c-c++-common/gomp/pr99928-13.c: Ditto.
* c-c++-common/gomp/pr99928-14.c: Ditto.
* c-c++-common/gomp/pr99928-2.c: Ditto.
* c-c++-common/gomp/pr99928-3.c: Ditto.
* c-c++-common/gomp/pr99928-4.c: Ditto.
* c-c++-common/gomp/pr99928-5.c: Ditto.
* c-c++-common/gomp/pr99928-6.c: Ditto.
* c-c++-common/gomp/pr99928-7.c: Ditto.
* c-c++-common/gomp/pr99928-8.c: Ditto.
* c-c++-common/gomp/pr99928-9.c: Ditto.
* c-c++-common/gomp/task-detach-1.c: Ditto.
* c-c++-common/gomp/teams-2.c: Ditto.
* g++.dg/gomp/attrs-1.C: Ditto.
* g++.dg/gomp/attrs-2.C: Ditto.
* g++.dg/gomp/attrs-4.C: Ditto.
* g++.dg/gomp/block-0.C: Ditto.
* g++.dg/gomp/block-10.C: Ditto.
* g++.dg/gomp/block-5.C: Ditto.
* g++.dg/gomp/block-9.C: Ditto.
* g++.dg/gomp/depend-iterator-1.C: Ditto.
* g++.dg/gomp/master-1.C: Ditto.
* g++.dg/gomp/master-2.C: Ditto.
* g++.dg/gomp/master-3.C: Ditto.
* g++.dg/gomp/method-1.C: Ditto.
* g++.dg/gomp/pr29965-3.C: Ditto.
* g++.dg/gomp/pr29965-9.C: Ditto.
* g++.dg/gomp/pr78363-4.C: Ditto.
* g++.dg/gomp/pr78363-6.C: Ditto.
* g++.dg/gomp/pr79664.C: Ditto.
* g++.dg/gomp/pr94477.C: Ditto.
* g++.dg/gomp/pr94512.C: Ditto.
* g++.dg/gomp/tpl-master-1.C: Ditto.
* gcc.dg/gomp/appendix-a/a.12.1.c: Ditto.
* gcc.dg/gomp/appendix-a/a.33.2.c: Ditto.
* gcc.dg/gomp/attrs-1.c: Ditto.
* gcc.dg/gomp/attrs-2.c: Ditto.
* gcc.dg/gomp/attrs-4.c: Ditto.
* gcc.dg/gomp/block-10.c: Ditto.
* gcc.dg/gomp/block-5.c: Ditto.
* gcc.dg/gomp/block-9.c: Ditto.
* gcc.dg/gomp/master-1.c: Ditto.
* gcc.dg/gomp/master-2.c: Ditto.
* gcc.dg/gomp/master-3.c: Ditto.
* gcc.dg/gomp/nesting-1.c: Ditto.
* gcc.dg/gomp/pr104517.c: Ditto.
* gcc.dg/gomp/pr29965-3.c: Ditto.
* gcc.dg/gomp/pr35818.c: Ditto.
* gcc.dg/gomp/pr91216.c: Ditto.
* gcc.dg/gomp/sharing-2.c: Ditto.
* gfortran.dg/gomp/adjust-args-10.f90: Ditto.
* gfortran.dg/gomp/affinity-1.f90: Ditto.
* gfortran.dg/gomp/allocate-clause.f90: Ditto.
* gfortran.dg/gomp/appendix-a/a.12.1.f90: Ditto.
* gfortran.dg/gomp/appendix-a/a.33.2.f90: Ditto.
* gfortran.dg/gomp/c_ptr_tests_20.f90: Ditto.
* gfortran.dg/gomp/c_ptr_tests_21.f90: Ditto.
* gfortran.dg/gomp/cancel-1.f90: Ditto.
* gfortran.dg/gomp/clauses-1.f90: Ditto.
* gfortran.dg/gomp/declare-variant-1.f90: Ditto.
* gfortran.dg/gomp/depend-iterator-1.f90: Ditto.
* gfortran.dg/gomp/depend-iterator-2.f90: Ditto.
* gfortran.dg/gomp/is_device_ptr-1.f90: Ditto.
* gfortran.dg/gomp/is_device_ptr-2.f90: Ditto.
* gfortran.dg/gomp/is_device_ptr-3.f90: Ditto.
* gfortran.dg/gomp/lastprivate-conditional-1.f90: Ditto.
* gfortran.dg/gomp/loop-4.f90: Ditto.
* gfortran.dg/gomp/loop-exit.f90: Ditto.
* gfortran.dg/gomp/map-3.f90: Ditto.
* gfortran.dg/gomp/nesting-2.f90: Ditto.
* gfortran.dg/gomp/nesting-3.f90: Ditto.
* gfortran.dg/gomp/nowait-2.f90: Ditto.
* gfortran.dg/gomp/nowait-4.f90: Ditto.
* gfortran.dg/gomp/nowait-5.f90: Ditto.
* gfortran.dg/gomp/openmp-simd-2.f90: Ditto.
* gfortran.dg/gomp/openmp-simd-3.f90: Ditto.
* gfortran.dg/gomp/parallel-master-1.f90: Ditto.
* gfortran.dg/gomp/parallel-master-2.f90: Ditto.
* gfortran.dg/gomp/pr107214-8.f90: Ditto.
* gfortran.dg/gomp/pr48117.f90: Ditto.
* gfortran.dg/gomp/pr94672.f90: Ditto.
* gfortran.dg/gomp/pr99928-1.f90: Suppression + fix whitespace.
* gfortran.dg/gomp/pr99928-11.f90: Suppression.
* gfortran.dg/gomp/pr99928-2.f90: Suppression + fix whitespace.
* gfortran.dg/gomp/pr99928-3.f90: Ditto.
* gfortran.dg/gomp/pr99928-4.f90: Ditto.
* gfortran.dg/gomp/pr99928-5.f90: Ditto.
* gfortran.dg/gomp/pr99928-6.f90: Ditto.
* gfortran.dg/gomp/pr99928-8.f90: Ditto.
* gfortran.dg/gomp/sharing-3.f90: Suppress deprecation warnings.
* gfortran.dg/gomp/strictly-structured-block-1.f90: Ditto.
* gfortran.dg/gomp/strictly-structured-block-2.f90: Ditto.
* gfortran.dg/gomp/target1.f90: Ditto.
* gfortran.dg/gomp/taskloop-1.f90: Ditto.
* gfortran.dg/gomp/taskloop-2.f90: Ditto.
* gfortran.dg/openmp-define-3.f90: Bump expected version.
* c-c++-common/gomp/master-construct-dep.c: New test.
* gfortran.dg/gomp/master-construct-dep.f90: New test.
1270 lines
46 KiB
Fortran
1270 lines
46 KiB
Fortran
! { dg-do run }
|
|
! { dg-additional-options "-Wno-deprecated-openmp" }
|
|
! 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 (type, external)
|
|
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 (type, external)
|
|
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)) stop 1
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 2
|
|
|
|
!$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)) stop 3
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 4
|
|
|
|
!$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)) stop 5
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 6
|
|
|
|
|
|
!$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))) stop 7
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 8
|
|
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)) stop 9
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 10
|
|
|
|
! 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)) stop 11
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 12
|
|
|
|
! 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)) stop 13
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 14
|
|
!$omp end target data
|
|
|
|
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) stop 15
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 16
|
|
|
|
|
|
!$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)) stop 17
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 18
|
|
|
|
! 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)) stop 19
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 20
|
|
|
|
! 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)) stop 21
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 22
|
|
!$omp end target data
|
|
|
|
if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) stop 23
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) stop 24
|
|
|
|
|
|
!$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)) stop 25
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 26
|
|
|
|
! 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)) stop 27
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 28
|
|
|
|
! 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)) stop 29
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) stop 30
|
|
!$omp end target data
|
|
|
|
if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) stop 31
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 32
|
|
|
|
|
|
!$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))) stop 33
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) stop 34
|
|
|
|
! 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))) stop 35
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 36
|
|
|
|
! 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))) stop 37
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 38
|
|
!$omp end target data
|
|
|
|
if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) stop 39
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 40
|
|
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 (type, external)
|
|
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)) stop 41
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 42
|
|
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)) stop 43
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 44
|
|
|
|
! 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)) stop 45
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 46
|
|
|
|
! 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)) stop 47
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 48
|
|
!$omp end target data
|
|
|
|
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) stop 49
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 50
|
|
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 (type, external)
|
|
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)
|
|
call test_dummy_opt_callee_1_absent(N=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)) stop 51
|
|
if (.not.present(cc) .or. .not.present(dd)) stop 52
|
|
if (.not.present(ee) .or. .not.present(ff)) stop 53
|
|
if (.not.present(gg) .or. .not.present(hh)) stop 54
|
|
|
|
if (.not.associated(ee) .or. .not.associated(ff)) stop 55
|
|
|
|
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
|
|
if (.not.present(aa) .or. .not.present(bb)) stop 56
|
|
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 57
|
|
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)) stop 58
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 59
|
|
|
|
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
|
|
if (.not.present(cc) .or. .not.present(dd)) stop 60
|
|
if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 61
|
|
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)) stop 62
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 63
|
|
|
|
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
|
|
if (.not.present(ee) .or. .not.present(ff)) stop 64
|
|
if (.not.associated(ee) .or. .not.associated(ff)) stop 65
|
|
if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 66
|
|
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)) stop 67
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 68
|
|
|
|
!$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
|
|
if (.not.present(gg) .or. .not.present(hh)) stop 69
|
|
if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) stop 70
|
|
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))) stop 71
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 72
|
|
end subroutine test_dummy_opt_callee_1
|
|
|
|
subroutine test_dummy_opt_callee_1_absent(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
|
|
|
|
integer :: err
|
|
|
|
! All shall be absent
|
|
if (present(aa) .or. present(bb)) stop 243
|
|
if (present(cc) .or. present(dd)) stop 244
|
|
if (present(ee) .or. present(ff)) stop 245
|
|
if (present(gg) .or. present(hh)) stop 246
|
|
|
|
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
|
|
if (present(aa) .or. present(bb)) stop 247
|
|
!$omp end target data
|
|
|
|
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
|
|
if (present(cc) .or. present(dd)) stop 248
|
|
!$omp end target data
|
|
|
|
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
|
|
if (present(ee) .or. present(ff)) stop 249
|
|
!$omp end target data
|
|
|
|
!$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
|
|
if (present(gg) .or. present(hh)) stop 250
|
|
!$omp end target data
|
|
end subroutine test_dummy_opt_callee_1_absent
|
|
|
|
! 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)) stop 73
|
|
if (.not.present(cc) .or. .not.present(dd)) stop 74
|
|
if (.not.present(ee) .or. .not.present(ff)) stop 75
|
|
if (.not.present(gg) .or. .not.present(hh)) stop 76
|
|
|
|
if (.not.associated(ee) .or. .not.associated(ff)) stop 77
|
|
|
|
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)) stop 78
|
|
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 79
|
|
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)) stop 80
|
|
if (.not.associated(aptr) .or. .not.associated(bptr)) stop 81
|
|
!$omp end target data
|
|
|
|
if (.not.present(aa) .or. .not.present(bb)) stop 82
|
|
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 83
|
|
if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 84
|
|
if (.not.associated(aptr) .or. .not.associated(bptr)) stop 85
|
|
|
|
! 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)) stop 86
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 87
|
|
|
|
! 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)) stop 88
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 89
|
|
|
|
! 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)) stop 90
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 91
|
|
!$omp end target data
|
|
|
|
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) stop 92
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 93
|
|
|
|
|
|
!$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)) stop 94
|
|
if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 95
|
|
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)) stop 96
|
|
if (.not.associated(cptr) .or. .not.associated(dptr)) stop 97
|
|
!$omp end target data
|
|
if (.not.present(cc) .or. .not.present(dd)) stop 98
|
|
if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 99
|
|
if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 100
|
|
if (.not.associated(cptr) .or. .not.associated(dptr)) stop 101
|
|
|
|
! 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)) stop 102
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 103
|
|
|
|
! 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)) stop 104
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 105
|
|
|
|
! 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)) stop 106
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 107
|
|
!$omp end target data
|
|
|
|
if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) stop 108
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) stop 109
|
|
|
|
|
|
!$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)) stop 110
|
|
if (.not.associated(ee) .or. .not.associated(ff)) stop 111
|
|
if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 112
|
|
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)) stop 113
|
|
if (.not.associated(eptr) .or. .not.associated(fptr)) stop 114
|
|
!$omp end target data
|
|
if (.not.present(ee) .or. .not.present(ff)) stop 115
|
|
if (.not.associated(ee) .or. .not.associated(ff)) stop 116
|
|
if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 117
|
|
if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 118
|
|
if (.not.associated(eptr) .or. .not.associated(fptr)) stop 119
|
|
|
|
! 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)) stop 120
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 121
|
|
|
|
! 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)) stop 122
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 123
|
|
|
|
! 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)) stop 124
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) stop 125
|
|
!$omp end target data
|
|
|
|
if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) stop 126
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 127
|
|
|
|
|
|
!$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)) stop 128
|
|
if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) stop 129
|
|
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)) stop 130
|
|
if (.not.associated(gptr) .or. .not.associated(hptr)) stop 131
|
|
!$omp end target data
|
|
if (.not.present(gg) .or. .not.present(hh)) stop 132
|
|
if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) stop 133
|
|
if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) stop 134
|
|
if (.not.associated(gptr) .or. .not.associated(hptr)) stop 135
|
|
|
|
! 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))) stop 136
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) stop 137
|
|
|
|
! 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))) stop 138
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 139
|
|
|
|
! 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))) stop 140
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 141
|
|
!$omp end target data
|
|
|
|
if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) stop 142
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 143
|
|
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 (type, external)
|
|
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)) stop 144
|
|
|
|
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
|
|
if (.not.present(aa) .or. .not.present(bb)) stop 145
|
|
if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 146
|
|
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)) stop 147
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 148
|
|
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)) stop 149
|
|
if (.not.present(c_aptr) .or. .not.present(c_bptr)) stop 150
|
|
if (.not.present(aptr) .or. .not.present(bptr)) stop 151
|
|
|
|
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)) stop 152
|
|
if (.not.present(c_aptr) .or. .not.present(c_bptr)) stop 153
|
|
if (.not.present(aptr) .or. .not.present(bptr)) stop 154
|
|
|
|
!$omp target data map(alloc:dummy) use_device_addr(aa,bb)
|
|
if (.not.present(aa) .or. .not.present(bb)) stop 155
|
|
if (.not.present(c_aptr) .or. .not.present(c_bptr)) stop 156
|
|
if (.not.present(aptr) .or. .not.present(bptr)) stop 157
|
|
|
|
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)) stop 158
|
|
if (.not.associated(aptr) .or. .not.associated(bptr)) stop 159
|
|
!$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)) stop 160
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 161
|
|
|
|
! 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)) stop 162
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 163
|
|
|
|
! 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)) stop 164
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 165
|
|
!$omp end target data
|
|
|
|
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) stop 166
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 167
|
|
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 (type, external)
|
|
private
|
|
public :: test_nullptr_1
|
|
contains
|
|
subroutine test_nullptr_1()
|
|
! scalars
|
|
real(c_double), pointer :: aa, bb
|
|
real(c_double), pointer :: ee, ff
|
|
|
|
real(c_double), allocatable, target :: gg, hh
|
|
|
|
type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr
|
|
real(c_double), pointer :: aptr, bptr, eptr, fptr, gptr, hptr
|
|
|
|
aa => null()
|
|
bb => null()
|
|
ee => null()
|
|
ff => null()
|
|
|
|
if (associated(aa) .or. associated(bb)) stop 168
|
|
!$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))) stop 169
|
|
c_aptr = c_loc(aa)
|
|
c_bptr = c_loc(bb)
|
|
aptr => aa
|
|
bptr => bb
|
|
if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 170
|
|
if (associated(aptr) .or. associated(bptr, bb)) stop 171
|
|
!$omp end target data
|
|
if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 172
|
|
if (associated(aptr) .or. associated(bptr, bb)) stop 173
|
|
|
|
if (allocated(gg)) stop 174
|
|
!$omp target data map(tofrom:gg) use_device_addr(gg)
|
|
if (c_associated(c_loc(gg))) stop 175
|
|
c_gptr = c_loc(gg)
|
|
gptr => gg
|
|
if (c_associated(c_gptr)) stop 176
|
|
if (associated(gptr)) stop 177
|
|
if (allocated(gg)) stop 178
|
|
!$omp end target data
|
|
if (c_associated(c_gptr)) stop 179
|
|
if (associated(gptr)) stop 180
|
|
if (allocated(gg)) stop 181
|
|
|
|
call test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr)
|
|
end subroutine test_nullptr_1
|
|
|
|
subroutine test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr)
|
|
! scalars
|
|
real(c_double), optional, pointer :: ee, ff
|
|
real(c_double), optional, allocatable, target :: hh
|
|
|
|
type(c_ptr), optional :: c_eptr, c_fptr, c_hptr
|
|
real(c_double), optional, pointer :: eptr, fptr, hptr
|
|
|
|
if (.not.present(ee) .or. .not.present(ff)) stop 182
|
|
if (associated(ee) .or. associated(ff)) stop 183
|
|
|
|
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
|
|
if (.not.present(ee) .or. .not.present(ff)) stop 184
|
|
if (associated(ee) .or. associated(ff)) stop 185
|
|
if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) stop 186
|
|
c_eptr = c_loc(ee)
|
|
c_fptr = c_loc(ff)
|
|
eptr => ee
|
|
fptr => ff
|
|
if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 187
|
|
if (associated(eptr) .or. associated(fptr)) stop 188
|
|
!$omp end target data
|
|
|
|
if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 189
|
|
if (associated(eptr) .or. associated(fptr)) stop 190
|
|
if (associated(ee) .or. associated(ff)) stop 191
|
|
|
|
|
|
if (.not.present(hh)) stop 192
|
|
if (allocated(hh)) stop 193
|
|
|
|
!$omp target data map(tofrom:hh) use_device_addr(hh)
|
|
if (.not.present(hh)) stop 194
|
|
if (allocated(hh)) stop 195
|
|
if (c_associated(c_loc(hh))) stop 196
|
|
c_hptr = c_loc(hh)
|
|
hptr => hh
|
|
if (c_associated(c_hptr)) stop 197
|
|
if (associated(hptr)) stop 198
|
|
if (allocated(hh)) stop 199
|
|
!$omp end target data
|
|
|
|
if (c_associated(c_hptr)) stop 200
|
|
if (associated(hptr)) stop 201
|
|
if (allocated(hh)) stop 202
|
|
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 (type, external)
|
|
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)) stop 203
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 204
|
|
|
|
!$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)) stop 205
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 206
|
|
|
|
!$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)) stop 207
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 208
|
|
|
|
|
|
!$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))) stop 209
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 210
|
|
|
|
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)) stop 211
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 212
|
|
|
|
! 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)) stop 213
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 214
|
|
|
|
! 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)) stop 215
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 216
|
|
!$omp end target data
|
|
|
|
if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) stop 217
|
|
if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 218
|
|
|
|
|
|
!$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)) stop 219
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 220
|
|
|
|
! 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)) stop 221
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 222
|
|
|
|
! 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)) stop 223
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 224
|
|
!$omp end target data
|
|
|
|
if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) stop 225
|
|
if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd)) stop 226
|
|
|
|
|
|
!$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)) stop 227
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 228
|
|
|
|
! 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)) stop 229
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 230
|
|
|
|
! 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)) stop 231
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) stop 232
|
|
!$omp end target data
|
|
|
|
if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) stop 233
|
|
if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 234
|
|
|
|
|
|
!$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))) stop 235
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) stop 236
|
|
|
|
! 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))) stop 237
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 238
|
|
|
|
! 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))) stop 239
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 240
|
|
!$omp end target data
|
|
|
|
if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) stop 241
|
|
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 242
|
|
|
|
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 (type, external)
|
|
|
|
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
|