+2019-11-01 Tobias Burnus <tobias@codesourcery.com>
+
+ * hooks.c (hook_tree_tree_bool_null): New.
+ * hooks.h (hook_tree_tree_bool_null): Declare.
+ * langhooks-def.h (LANG_HOOKS_OMP_ARRAY_DATA): Define.
+ (LANG_HOOKS_DECLS): Add it.
+ * langhooks.h (lang_hooks_for_decls): Add omp_array_data.
+ * omp-low.c (install_var_field): New mode for Fortran descriptor arrays.
+ (lower_omp_target): Handle Fortran array with descriptor in
+ OMP_CLAUSE_USE_DEVICE_ADDR/OMP_CLAUSE_USE_DEVICE_PTR.
+
2019-10-31 Richard Sandiford <richard.sandiford@arm.com>
* config/aarch64/aarch64-sve-builtins.cc (register_builtin_types):
+2019-11-01 Tobias Burnus <tobias@codesourcery.com>
+
+ * f95-lang.c (LANG_HOOKS_OMP_ARRAY_DATA): Set to gfc_omp_array_data.
+ * trans-array.c (gfc_conv_descriptor_data_get): Handle also
+ REFERENCE_TYPE.
+ * trans-openmp.c (gfc_omp_array_data): New.
+ * trans.h (gfc_omp_array_data): New prototype.
+
2019-10-31 Tobias Burnus <tobias@codesourcery.com>
PR fortran/92284.
#undef LANG_HOOKS_TYPE_FOR_MODE
#undef LANG_HOOKS_TYPE_FOR_SIZE
#undef LANG_HOOKS_INIT_TS
+#undef LANG_HOOKS_OMP_ARRAY_DATA
#undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR
#undef LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT
#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
#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_ARRAY_DATA gfc_omp_array_data
#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
tree field, type, t;
type = TREE_TYPE (desc);
+ if (TREE_CODE (type) == REFERENCE_TYPE)
+ type = TREE_TYPE (type);
+
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
field = TYPE_FIELDS (type);
&& GFC_DECL_OPTIONAL_ARGUMENT (decl));
}
+
+/* Returns tree with NULL if it is not an array descriptor and with the tree to
+ access the 'data' component otherwise. With type_only = true, it returns the
+ TREE_TYPE without creating a new tree. */
+
+tree
+gfc_omp_array_data (tree decl, bool type_only)
+{
+ tree type = TREE_TYPE (decl);
+
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+
+ if (!GFC_DESCRIPTOR_TYPE_P (type))
+ return NULL_TREE;
+
+ if (type_only)
+ return GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref (decl);
+
+ decl = gfc_conv_descriptor_data_get (decl);
+ STRIP_NOPS (decl);
+ return decl;
+}
+
/* True if OpenMP should privatize what this DECL points to rather
than the DECL itself. */
/* In trans-openmp.c */
bool gfc_omp_is_allocatable_or_ptr (const_tree);
bool gfc_omp_is_optional_argument (const_tree);
+tree gfc_omp_array_data (tree, bool);
bool gfc_omp_privatize_by_reference (const_tree);
enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree);
tree gfc_omp_report_decl (tree);
return NULL;
}
+tree
+hook_tree_tree_bool_null (tree, bool)
+{
+ return NULL;
+}
+
tree
hook_tree_tree_tree_null (tree, tree)
{
extern tree hook_tree_const_tree_null (const_tree);
extern tree hook_tree_void_null (void);
+extern tree hook_tree_tree_bool_null (tree, bool);
extern tree hook_tree_tree_tree_null (tree, tree);
extern tree hook_tree_tree_tree_tree_null (tree, tree, tree);
extern tree hook_tree_tree_int_treep_bool_null (tree, int, tree *, bool);
#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_ARRAY_DATA hook_tree_tree_bool_null
#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
LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL, \
LANG_HOOKS_POST_COMPILATION_PARSING_CLEANUPS, \
LANG_HOOKS_DECL_OK_FOR_SIBCALL, \
+ LANG_HOOKS_OMP_ARRAY_DATA, \
LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR, \
LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT, \
LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE, \
/* True if this decl may be called via a sibcall. */
bool (*ok_for_sibcall) (const_tree);
+ /* Return a tree for the actual data of an array descriptor - or NULL_TREE
+ if original tree is not an array descriptor. If the the second argument
+ is true, only the TREE_TYPE is returned without generating a new tree. */
+ tree (*omp_array_data) (tree, bool);
+
/* 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);
tree field, type, sfield = NULL_TREE;
splay_tree_key key = (splay_tree_key) var;
+ if ((mask & 16) != 0)
+ {
+ key = (splay_tree_key) &DECL_NAME (var);
+ gcc_checking_assert (key != (splay_tree_key) var);
+ }
if ((mask & 8) != 0)
{
key = (splay_tree_key) &DECL_UID (var);
|| !is_gimple_omp_oacc (ctx->stmt));
type = TREE_TYPE (var);
+ if ((mask & 16) != 0)
+ type = lang_hooks.decls.omp_array_data (var, true);
+
/* Prevent redeclaring the var in the split-off function with a restrict
pointer type. Note that we only clear type itself, restrict qualifiers in
the pointed-to type will be ignored by points-to analysis. */
side effect of making dwarf2out ignore this member, so for helpful
debugging we clear it later in delete_omp_context. */
DECL_ABSTRACT_ORIGIN (field) = var;
- if (type == TREE_TYPE (var))
+ if ((mask & 16) == 0 && type == TREE_TYPE (var))
{
SET_DECL_ALIGN (field, DECL_ALIGN (var));
DECL_USER_ALIGN (field) = DECL_USER_ALIGN (var);
case OMP_CLAUSE_USE_DEVICE_PTR:
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_allocatable_or_ptr (decl))
- || TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
+
+ /* Fortran array descriptors. */
+ if (lang_hooks.decls.omp_array_data (decl, true))
+ install_var_field (decl, false, 19, ctx);
+ else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
+ && !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
install_var_field (decl, false, 11, ctx);
}
else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
&& !omp_is_reference (var)
- && !omp_is_allocatable_or_ptr (var))
+ && !omp_is_allocatable_or_ptr (var)
+ && !lang_hooks.decls.omp_array_data (var, true))
|| TREE_CODE (TREE_TYPE (var)) == ARRAY_TYPE)
{
tree new_var = lookup_decl (var, ctx);
case OMP_CLAUSE_IS_DEVICE_PTR:
ovar = OMP_CLAUSE_DECL (c);
var = lookup_decl_in_outer_ctx (ovar, ctx);
- if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR)
+
+ if (lang_hooks.decls.omp_array_data (ovar, true))
+ {
+ tkind = (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR
+ ? GOMP_MAP_USE_DEVICE_PTR : GOMP_MAP_FIRSTPRIVATE_INT);
+ x = build_sender_ref ((splay_tree_key) &DECL_NAME (ovar), ctx);
+ }
+ else if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR)
{
tkind = GOMP_MAP_USE_DEVICE_PTR;
x = build_sender_ref ((splay_tree_key) &DECL_UID (ovar), ctx);
x = build_sender_ref (ovar, ctx);
}
type = TREE_TYPE (ovar);
- if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
- && !omp_is_reference (ovar)
- && !omp_is_allocatable_or_ptr (ovar))
- || TREE_CODE (type) == ARRAY_TYPE)
+ if (lang_hooks.decls.omp_array_data (ovar, true))
+ var = lang_hooks.decls.omp_array_data (ovar, false);
+ else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
+ && !omp_is_reference (ovar)
+ && !omp_is_allocatable_or_ptr (ovar))
+ || TREE_CODE (type) == ARRAY_TYPE)
var = build_fold_addr_expr (var);
else
{
case OMP_CLAUSE_USE_DEVICE_ADDR:
case OMP_CLAUSE_IS_DEVICE_PTR:
var = OMP_CLAUSE_DECL (c);
+ bool is_array_data;
+ is_array_data = lang_hooks.decls.omp_array_data (var, true) != NULL;
+
if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR)
- x = build_sender_ref ((splay_tree_key) &DECL_UID (var), ctx);
+ x = build_sender_ref (is_array_data
+ ? (splay_tree_key) &DECL_NAME (var)
+ : (splay_tree_key) &DECL_UID (var), ctx);
else
x = build_receiver_ref (var, false, ctx);
- if (is_variable_sized (var))
+
+ if (is_array_data)
+ {
+ bool is_ref = omp_is_reference (var);
+ /* First, we copy the descriptor data from the host; then
+ we update its data to point to the target address. */
+ tree new_var = lookup_decl (var, ctx);
+ new_var = DECL_VALUE_EXPR (new_var);
+ tree v = new_var;
+
+ if (is_ref)
+ {
+ var = build_fold_indirect_ref (var);
+ gimplify_expr (&var, &new_body, NULL, is_gimple_val,
+ fb_rvalue);
+ v = create_tmp_var_raw (TREE_TYPE (var), get_name (var));
+ gimple_add_tmp_var (v);
+ TREE_ADDRESSABLE (v) = 1;
+ gimple_seq_add_stmt (&new_body,
+ gimple_build_assign (v, var));
+ tree rhs = build_fold_addr_expr (v);
+ gimple_seq_add_stmt (&new_body,
+ gimple_build_assign (new_var, rhs));
+ }
+ else
+ gimple_seq_add_stmt (&new_body,
+ gimple_build_assign (new_var, var));
+
+ tree v2 = lang_hooks.decls.omp_array_data (unshare_expr (v), false);
+ gcc_assert (v2);
+ gimplify_expr (&x, &new_body, NULL, is_gimple_val, fb_rvalue);
+ gimple_seq_add_stmt (&new_body,
+ gimple_build_assign (v2, x));
+ }
+ else if (is_variable_sized (var))
{
tree pvar = DECL_VALUE_EXPR (var);
gcc_assert (TREE_CODE (pvar) == INDIRECT_REF);
+2019-11-01 Tobias Burnus <tobias@codesourcery.com>
+
+ * testsuite/libgomp.fortran/use_device_addr-1.f90 (test_nullptr_1,
+ test_dummy_opt_nullptr_callee_1): Add present but unallocated test.
+ * testsuite/libgomp.fortran/use_device_addr-2.f90: Likewise.
+ * testsuite/libgomp.fortran/use_device_addr-3.f90: New.
+ * testsuite/libgomp.fortran/use_device_addr-4.f90: New.
+ * testsuite/testsuite/libgomp.fortran/use_device_ptr-1.f90: New.
+
2019-10-30 Tobias Burnus <tobias@codesourcery.com>
* testsuite/libgomp.fortran/target9.f90: New.
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
+ 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()
if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 1
if (associated(aptr) .or. associated(bptr, bb)) stop 1
- call test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
+ if (allocated(gg)) stop 1
+ !$omp target data map(tofrom:gg) use_device_addr(gg)
+ if (c_associated(c_loc(gg))) stop 1
+ c_gptr = c_loc(gg)
+ gptr => gg
+ if (c_associated(c_gptr)) stop 1
+ if (associated(gptr)) stop 1
+ if (allocated(gg)) stop 1
+ !$omp end target data
+ if (c_associated(c_gptr)) stop 1
+ if (associated(gptr)) stop 1
+ if (allocated(gg)) stop 1
+
+ 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, c_eptr, c_fptr, eptr, fptr)
+ 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
- real(c_double), optional, pointer :: eptr, fptr
+ 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 1
if (associated(ee) .or. associated(ff)) stop 1
if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 1
if (associated(eptr) .or. associated(fptr)) stop 1
+ if (associated(ee) .or. associated(ff)) stop 1
+
+
+ if (.not.present(hh)) stop 1
+ if (allocated(hh)) stop 1
+
+ !$omp target data map(tofrom:hh) use_device_addr(hh)
+ if (.not.present(hh)) stop 1
+ if (allocated(hh)) stop 1
+ if (c_associated(c_loc(hh))) stop 1
+ c_hptr = c_loc(hh)
+ hptr => hh
+ if (c_associated(c_hptr)) stop 1
+ if (associated(hptr)) stop 1
+ if (allocated(hh)) stop 1
+ !$omp end target data
+
+ if (c_associated(c_hptr)) stop 1
+ if (associated(hptr)) stop 1
+ if (allocated(hh)) stop 1
end subroutine test_dummy_opt_nullptr_callee_1
end module test_nullptr
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
+ real(c_float), allocatable, target :: gg, hh
+
+ type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_float), pointer :: aptr, bptr, eptr, fptr, gptr, hptr
aa => null()
bb => null()
if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 1
if (associated(aptr) .or. associated(bptr, bb)) stop 1
- call test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr)
+ if (allocated(gg)) stop 1
+ !$omp target data map(tofrom:gg) use_device_addr(gg)
+ if (c_associated(c_loc(gg))) stop 1
+ c_gptr = c_loc(gg)
+ gptr => gg
+ if (c_associated(c_gptr)) stop 1
+ if (associated(gptr)) stop 1
+ if (allocated(gg)) stop 1
+ !$omp end target data
+ if (c_associated(c_gptr)) stop 1
+ if (associated(gptr)) stop 1
+ if (allocated(gg)) stop 1
+
+ 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, c_eptr, c_fptr, eptr, fptr)
+ subroutine test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr)
! scalars
real(c_float), optional, pointer :: ee, ff
+ real(c_float), optional, allocatable, target :: hh
- type(c_ptr), optional :: c_eptr, c_fptr
- real(c_float), optional, pointer :: eptr, fptr
+ type(c_ptr), optional :: c_eptr, c_fptr, c_hptr
+ real(c_float), optional, pointer :: eptr, fptr, hptr
if (.not.present(ee) .or. .not.present(ff)) stop 1
if (associated(ee) .or. associated(ff)) stop 1
if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 1
if (associated(eptr) .or. associated(fptr)) stop 1
+ if (associated(ee) .or. associated(ff)) stop 1
+
+
+ if (.not.present(hh)) stop 1
+ if (allocated(hh)) stop 1
+
+ !$omp target data map(tofrom:hh) use_device_addr(hh)
+ if (.not.present(hh)) stop 1
+ if (allocated(hh)) stop 1
+ if (c_associated(c_loc(hh))) stop 1
+ c_hptr = c_loc(hh)
+ hptr => hh
+ if (c_associated(c_hptr)) stop 1
+ if (associated(hptr)) stop 1
+ if (allocated(hh)) stop 1
+ !$omp end target data
+
+ if (c_associated(c_hptr)) stop 1
+ if (associated(hptr)) stop 1
+ if (allocated(hh)) stop 1
end subroutine test_dummy_opt_nullptr_callee_1
end module test_nullptr
--- /dev/null
+! Comprehensive run-time test for use_device_addr
+!
+! Tests array with array descriptor
+!
+! Differs from use_device_addr-4.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:
+! - scalars
+! - polymorphic variables
+! - absent optional arguments
+!
+module target_procs
+ use iso_c_binding
+ implicit none (type, external)
+ private
+ public :: copy3_array
+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_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
+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
+
+ real(c_double), target :: aa(N), bb(N)
+ real(c_double), target, allocatable :: cc(:), dd(:)
+ real(c_double), pointer :: ee(:), ff(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+
+ aa = 11.0_c_double
+ bb = 22.0_c_double
+ cc = 33.0_c_double
+ dd = 44.0_c_double
+ ee = 55.0_c_double
+ ff = 66.0_c_double
+
+ call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, N)
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_dummy_call_1
+
+ subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, N)
+ real(c_double), target :: aa(:), bb(:)
+ real(c_double), target, allocatable :: cc(:), dd(:)
+ real(c_double), pointer :: ee(:), ff(:)
+
+ integer, value :: N
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_array(c_loc(aa), c_loc(bb), N)
+ !$omp end target data
+ if (any(abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ call copy3_array(c_loc(cc), c_loc(dd), N)
+ !$omp end target data
+ if (any(abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ call copy3_array(c_loc(ee), c_loc(ff), N)
+ !$omp end target data
+ if (any(abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+ end subroutine test_dummy_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_call_2()
+ integer, parameter :: N = 1000
+
+ real(c_double), target :: aa(N), bb(N)
+ real(c_double), target, allocatable :: cc(:), dd(:)
+ real(c_double), pointer :: ee(:), ff(:)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
+ real(c_double), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+
+ call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, &
+ N)
+ deallocate(ee, ff)
+ end subroutine test_dummy_call_2
+
+ subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, &
+ N)
+ real(c_double), target :: aa(:), bb(:)
+ real(c_double), target, allocatable :: cc(:), dd(:)
+ real(c_double), pointer :: ee(:), ff(:)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
+ real(c_double), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:)
+
+ 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
+
+ !$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_array(c_aptr, c_bptr, N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_array(c_aptr, c_bptr, N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_array(c_loc(aptr), c_loc(bptr), N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1
+ !$omp end target data
+
+ if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1
+
+
+ !$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_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_double
+ !$omp target update to(cc)
+ call copy3_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_double
+ !$omp target update to(cc)
+ call copy3_array(c_loc(cptr), c_loc(dptr), N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+ !$omp end target data
+
+ if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd))) stop 1
+
+
+ !$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_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_double
+ !$omp target update to(ee)
+ call copy3_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_double
+ !$omp target update to(ee)
+ call copy3_array(c_loc(eptr), c_loc(fptr), N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff))) stop 1
+ !$omp end target data
+
+ if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+ end subroutine test_dummy_callee_2
+end module test_dummies
+
+
+
+! 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
+
+ real(c_double), target :: aa(N), bb(N)
+ real(c_double), target, allocatable :: cc(:), dd(:)
+ real(c_double), pointer :: ee(:), ff(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+
+ aa = 11.0_c_double
+ bb = 22.0_c_double
+ cc = 33.0_c_double
+ dd = 44.0_c_double
+ ee = 55.0_c_double
+ ff = 66.0_c_double
+
+ call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, 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, N)
+ ! scalars
+ real(c_double), optional, target :: aa(:), bb(:)
+ real(c_double), optional, target, allocatable :: cc(:), dd(:)
+ real(c_double), optional, pointer :: ee(:), ff(:)
+
+ integer, value :: N
+
+ ! All shall be present - and pointing to non-NULL
+ if (.not.present(aa) .or. .not.present(bb)) stop 1
+ if (.not.present(cc) .or. .not.present(dd)) stop 1
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+
+ if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1
+ if (.not.associated(ee) .or. .not.associated(ff)) stop 1
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) stop 1
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1
+ call copy3_array(c_loc(aa), c_loc(bb), N)
+ !$omp end target data
+ if (any(abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ if (.not.present(cc) .or. .not.present(dd)) stop 1
+ if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1
+ call copy3_array(c_loc(cc), c_loc(dd), N)
+ !$omp end target data
+ if (any(abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+ if (.not.associated(ee) .or. .not.associated(ff)) stop 1
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1
+ call copy3_array(c_loc(ee), c_loc(ff), N)
+ !$omp end target data
+ if (any(abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+ end subroutine test_dummy_opt_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_opt_call_2()
+ integer, parameter :: N = 1000
+
+ real(c_double), target :: aa(N), bb(N)
+ real(c_double), target, allocatable :: cc(:), dd(:)
+ real(c_double), pointer :: ee(:), ff(:)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
+ real(c_double), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+ call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, &
+ N)
+ deallocate(ee, ff)
+ end subroutine test_dummy_opt_call_2
+
+ subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, &
+ N)
+ ! scalars
+ real(c_double), optional, target :: aa(:), bb(:)
+ real(c_double), optional, target, allocatable :: cc(:), dd(:)
+ real(c_double), optional, pointer :: ee(:), ff(:)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
+ real(c_double), optional, pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:)
+
+ 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 1
+ if (.not.present(cc) .or. .not.present(dd)) stop 1
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+
+ if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1
+ if (.not.associated(ee) .or. .not.associated(ff)) stop 1
+
+ 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
+
+ !$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 1
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1
+ 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 1
+ if (.not.associated(aptr) .or. .not.associated(bptr)) stop 1
+ !$omp end target data
+
+ if (.not.present(aa) .or. .not.present(bb)) stop 1
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 1
+ if (.not.associated(aptr) .or. .not.associated(bptr)) stop 1
+
+ ! check c_loc ptr once
+ call copy3_array(c_aptr, c_bptr, N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_double
+ !$omp target update to(aa)
+ call copy3_array(c_aptr, c_bptr, N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_double
+ !$omp target update to(aa)
+ call copy3_array(c_loc(aptr), c_loc(bptr), N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1
+ !$omp end target data
+
+ if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1
+
+ !$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 1
+ if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1
+ 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 1
+ if (.not.associated(cptr) .or. .not.associated(dptr)) stop 1
+ !$omp end target data
+ if (.not.present(cc) .or. .not.present(dd)) stop 1
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1
+ if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 1
+ if (.not.associated(cptr) .or. .not.associated(dptr)) stop 1
+
+ ! check c_loc ptr once
+ call copy3_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_double
+ !$omp target update to(cc)
+ call copy3_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_double
+ !$omp target update to(cc)
+ call copy3_array(c_loc(cptr), c_loc(dptr), N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+ !$omp end target data
+
+ if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd))) stop 1
+
+
+ !$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 1
+ if (.not.associated(ee) .or. .not.associated(ff)) stop 1
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1
+ 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 1
+ if (.not.associated(eptr) .or. .not.associated(fptr)) stop 1
+ !$omp end target data
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+ if (.not.associated(ee) .or. .not.associated(ff)) stop 1
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1
+ if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 1
+ if (.not.associated(eptr) .or. .not.associated(fptr)) stop 1
+
+ ! check c_loc ptr once
+ call copy3_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_double
+ !$omp target update to(ee)
+ call copy3_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_double
+ !$omp target update to(ee)
+ call copy3_array(c_loc(eptr), c_loc(fptr), N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff))) stop 1
+ !$omp end target data
+
+ if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+ end subroutine test_dummy_opt_callee_2
+end module test_dummies_opt
+
+
+
+! Test nullptr
+module test_nullptr
+ use iso_c_binding
+ implicit none (type, external)
+ private
+ public :: test_nullptr_1
+contains
+ subroutine test_nullptr_1()
+ 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 1
+ !$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 1
+ 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 1
+ if (associated(aptr) .or. associated(bptr, bb)) stop 1
+ if (associated(aa) .or. associated(bb)) stop 1
+ !$omp end target data
+ if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 1
+ if (associated(aptr) .or. associated(bptr, bb)) stop 1
+ if (associated(aa) .or. associated(bb)) stop 1
+
+ if (allocated(gg)) stop 1
+ !$omp target data map(tofrom:gg) use_device_addr(gg)
+ if (c_associated(c_loc(gg))) stop 1
+ c_gptr = c_loc(gg)
+ gptr => gg
+ if (c_associated(c_gptr)) stop 1
+ if (associated(gptr)) stop 1
+ if (allocated(gg)) stop 1
+ !$omp end target data
+ if (c_associated(c_gptr)) stop 1
+ if (associated(gptr)) stop 1
+ if (allocated(gg)) stop 1
+
+ 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 1
+ if (associated(ee) .or. associated(ff)) stop 1
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+ if (associated(ee) .or. associated(ff)) stop 1
+ if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) stop 1
+ 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 1
+ if (associated(eptr) .or. associated(fptr)) stop 1
+ !$omp end target data
+
+ if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 1
+ if (associated(eptr) .or. associated(fptr)) stop 1
+
+ if (allocated(hh)) stop 1
+ !$omp target data map(tofrom:hh) use_device_addr(hh)
+ if (c_associated(c_loc(hh))) stop 1
+ c_hptr = c_loc(hh)
+ hptr => hh
+ if (c_associated(c_hptr)) stop 1
+ if (associated(hptr)) stop 1
+ if (allocated(hh)) stop 1
+ !$omp end target data
+ if (c_associated(c_hptr)) stop 1
+ if (associated(hptr)) stop 1
+ if (allocated(hh)) stop 1
+ 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
+
+ real(c_double), target, allocatable :: cc(:), dd(:)
+ real(c_double), pointer :: ee(:), ff(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+
+ cc = 33.0_c_double
+ dd = 44.0_c_double
+ ee = 55.0_c_double
+ ff = 66.0_c_double
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ call copy3_array(c_loc(cc), c_loc(dd), N)
+ !$omp end target data
+ if (any(abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ call copy3_array(c_loc(ee), c_loc(ff), N)
+ !$omp end target data
+ if (any(abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_main_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_main_2
+ integer, parameter :: N = 1000
+
+ real(c_double), target, allocatable :: cc(:), dd(:)
+ real(c_double), pointer :: ee(:), ff(:)
+
+ real(c_double) :: dummy
+ type(c_ptr) :: c_cptr, c_dptr, c_eptr, c_fptr
+ real(c_double), pointer :: cptr(:), dptr(:), eptr(:), fptr(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+
+ cc = 333.0_c_double
+ dd = 444.0_c_double
+ ee = 555.0_c_double
+ ff = 666.0_c_double
+
+ !$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_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_double
+ !$omp target update to(cc)
+ call copy3_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_double
+ !$omp target update to(cc)
+ call copy3_array(c_loc(cptr), c_loc(dptr), N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1
+ !$omp end target data
+
+ if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd))) stop 1
+ if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd))) stop 1
+
+
+ !$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_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_double
+ !$omp target update to(ee)
+ call copy3_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_double
+ !$omp target update to(ee)
+ call copy3_array(c_loc(eptr), c_loc(fptr), N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff))) stop 1
+ !$omp end target data
+
+ if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
+
+ deallocate(ee, ff)
+ end subroutine test_main_2
+end module tests
+
+
+program omp_device_addr
+ use tests
+ use test_dummies
+ use test_dummies_opt
+ 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_opt_call_1()
+ call test_dummy_opt_call_2()
+
+ call test_nullptr_1()
+end program omp_device_addr
--- /dev/null
+! Comprehensive run-time test for use_device_addr
+!
+! Tests array with array descriptor
+!
+! Differs from use_device_addr-3.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:
+! - scalars
+! - polymorphic variables
+! - absent optional arguments
+!
+module target_procs
+ use iso_c_binding
+ implicit none (type, external)
+ private
+ public :: copy3_array
+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_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
+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
+
+ real(c_float), target :: aa(N), bb(N)
+ real(c_float), target, allocatable :: cc(:), dd(:)
+ real(c_float), pointer :: ee(:), ff(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+
+ 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
+
+ call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, N)
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_dummy_call_1
+
+ subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, N)
+ real(c_float), target :: aa(:), bb(:)
+ real(c_float), target, allocatable :: cc(:), dd(:)
+ real(c_float), pointer :: ee(:), ff(:)
+
+ integer, value :: N
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ call copy3_array(c_loc(aa), c_loc(bb), N)
+ !$omp end target data
+ if (any(abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ call copy3_array(c_loc(cc), c_loc(dd), N)
+ !$omp end target data
+ if (any(abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ call copy3_array(c_loc(ee), c_loc(ff), N)
+ !$omp end target data
+ if (any(abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+ end subroutine test_dummy_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_call_2()
+ integer, parameter :: N = 1000
+
+ real(c_float), target :: aa(N), bb(N)
+ real(c_float), target, allocatable :: cc(:), dd(:)
+ real(c_float), pointer :: ee(:), ff(:)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
+ real(c_float), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+
+ call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, &
+ N)
+ deallocate(ee, ff)
+ end subroutine test_dummy_call_2
+
+ subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, &
+ N)
+ real(c_float), target :: aa(:), bb(:)
+ real(c_float), target, allocatable :: cc(:), dd(:)
+ real(c_float), pointer :: ee(:), ff(:)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
+ real(c_float), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:)
+
+ 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
+
+ !$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_array(c_aptr, c_bptr, N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_float
+ !$omp target update to(aa)
+ call copy3_array(c_aptr, c_bptr, N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_float
+ !$omp target update to(aa)
+ call copy3_array(c_loc(aptr), c_loc(bptr), N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1
+ !$omp end target data
+
+ if (any(abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1
+
+
+ !$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_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_float
+ !$omp target update to(cc)
+ call copy3_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_float
+ !$omp target update to(cc)
+ call copy3_array(c_loc(cptr), c_loc(dptr), N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+ !$omp end target data
+
+ if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd))) stop 1
+
+
+ !$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_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_float
+ !$omp target update to(ee)
+ call copy3_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_float
+ !$omp target update to(ee)
+ call copy3_array(c_loc(eptr), c_loc(fptr), N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff))) stop 1
+ !$omp end target data
+
+ if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+ end subroutine test_dummy_callee_2
+end module test_dummies
+
+
+
+! 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
+
+ real(c_float), target :: aa(N), bb(N)
+ real(c_float), target, allocatable :: cc(:), dd(:)
+ real(c_float), pointer :: ee(:), ff(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+
+ 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
+
+ call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, 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, N)
+ ! scalars
+ real(c_float), optional, target :: aa(:), bb(:)
+ real(c_float), optional, target, allocatable :: cc(:), dd(:)
+ real(c_float), optional, pointer :: ee(:), ff(:)
+
+ integer, value :: N
+
+ ! All shall be present - and pointing to non-NULL
+ if (.not.present(aa) .or. .not.present(bb)) stop 1
+ if (.not.present(cc) .or. .not.present(dd)) stop 1
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+
+ if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1
+ if (.not.associated(ee) .or. .not.associated(ff)) stop 1
+
+ !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
+ if (.not.present(aa) .or. .not.present(bb)) stop 1
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1
+ call copy3_array(c_loc(aa), c_loc(bb), N)
+ !$omp end target data
+ if (any(abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ if (.not.present(cc) .or. .not.present(dd)) stop 1
+ if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1
+ call copy3_array(c_loc(cc), c_loc(dd), N)
+ !$omp end target data
+ if (any(abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+ if (.not.associated(ee) .or. .not.associated(ff)) stop 1
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1
+ call copy3_array(c_loc(ee), c_loc(ff), N)
+ !$omp end target data
+ if (any(abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+ end subroutine test_dummy_opt_callee_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_dummy_opt_call_2()
+ integer, parameter :: N = 1000
+
+ real(c_float), target :: aa(N), bb(N)
+ real(c_float), target, allocatable :: cc(:), dd(:)
+ real(c_float), pointer :: ee(:), ff(:)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
+ real(c_float), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+ call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, &
+ N)
+ deallocate(ee, ff)
+ end subroutine test_dummy_opt_call_2
+
+ subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, &
+ c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, &
+ aptr, bptr, cptr, dptr, eptr, fptr, &
+ N)
+ ! scalars
+ real(c_float), optional, target :: aa(:), bb(:)
+ real(c_float), optional, target, allocatable :: cc(:), dd(:)
+ real(c_float), optional, pointer :: ee(:), ff(:)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
+ real(c_float), optional, pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:)
+
+ integer, value :: N
+
+ real(c_float) :: dummy
+
+ ! All shall be present - and pointing to non-NULL
+ if (.not.present(aa) .or. .not.present(bb)) stop 1
+ if (.not.present(cc) .or. .not.present(dd)) stop 1
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+
+ if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1
+ if (.not.associated(ee) .or. .not.associated(ff)) stop 1
+
+ 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
+
+ !$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 1
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1
+ 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 1
+ if (.not.associated(aptr) .or. .not.associated(bptr)) stop 1
+ !$omp end target data
+
+ if (.not.present(aa) .or. .not.present(bb)) stop 1
+ if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1
+ if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 1
+ if (.not.associated(aptr) .or. .not.associated(bptr)) stop 1
+
+ ! check c_loc ptr once
+ call copy3_array(c_aptr, c_bptr, N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ aa = 1111.0_c_float
+ !$omp target update to(aa)
+ call copy3_array(c_aptr, c_bptr, N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ aa = 11111.0_c_float
+ !$omp target update to(aa)
+ call copy3_array(c_loc(aptr), c_loc(bptr), N)
+ !$omp target update from(bb)
+ if (any(abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1
+ !$omp end target data
+
+ if (any(abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1
+ if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1
+
+ !$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 1
+ if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1
+ 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 1
+ if (.not.associated(cptr) .or. .not.associated(dptr)) stop 1
+ !$omp end target data
+ if (.not.present(cc) .or. .not.present(dd)) stop 1
+ if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1
+ if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 1
+ if (.not.associated(cptr) .or. .not.associated(dptr)) stop 1
+
+ ! check c_loc ptr once
+ call copy3_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_float
+ !$omp target update to(cc)
+ call copy3_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_float
+ !$omp target update to(cc)
+ call copy3_array(c_loc(cptr), c_loc(dptr), N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+ !$omp end target data
+
+ if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd))) stop 1
+
+
+ !$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 1
+ if (.not.associated(ee) .or. .not.associated(ff)) stop 1
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1
+ 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 1
+ if (.not.associated(eptr) .or. .not.associated(fptr)) stop 1
+ !$omp end target data
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+ if (.not.associated(ee) .or. .not.associated(ff)) stop 1
+ if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1
+ if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 1
+ if (.not.associated(eptr) .or. .not.associated(fptr)) stop 1
+
+ ! check c_loc ptr once
+ call copy3_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_float
+ !$omp target update to(ee)
+ call copy3_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_float
+ !$omp target update to(ee)
+ call copy3_array(c_loc(eptr), c_loc(fptr), N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff))) stop 1
+ !$omp end target data
+
+ if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+ end subroutine test_dummy_opt_callee_2
+end module test_dummies_opt
+
+
+
+! Test nullptr
+module test_nullptr
+ use iso_c_binding
+ implicit none (type, external)
+ private
+ public :: test_nullptr_1
+contains
+ subroutine test_nullptr_1()
+ real(c_float), pointer :: aa(:), bb(:)
+ real(c_float), pointer :: ee(:), ff(:)
+
+ real(c_float), allocatable, target :: gg(:), hh(:)
+
+ type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr
+ real(c_float), pointer :: aptr(:), bptr(:), eptr(:), fptr(:), gptr(:), hptr(:)
+
+ aa => null()
+ bb => null()
+ ee => null()
+ ff => null()
+
+ if (associated(aa) .or. associated(bb)) stop 1
+ !$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 1
+ 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 1
+ if (associated(aptr) .or. associated(bptr, bb)) stop 1
+ if (associated(aa) .or. associated(bb)) stop 1
+ !$omp end target data
+ if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 1
+ if (associated(aptr) .or. associated(bptr, bb)) stop 1
+ if (associated(aa) .or. associated(bb)) stop 1
+
+ if (allocated(gg)) stop 1
+ !$omp target data map(tofrom:gg) use_device_addr(gg)
+ if (c_associated(c_loc(gg))) stop 1
+ c_gptr = c_loc(gg)
+ gptr => gg
+ if (c_associated(c_gptr)) stop 1
+ if (associated(gptr)) stop 1
+ if (allocated(gg)) stop 1
+ !$omp end target data
+ if (c_associated(c_gptr)) stop 1
+ if (associated(gptr)) stop 1
+ if (allocated(gg)) stop 1
+
+ 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_float), optional, pointer :: ee(:), ff(:)
+ real(c_float), optional, allocatable, target :: hh(:)
+
+ type(c_ptr), optional :: c_eptr, c_fptr, c_hptr
+ real(c_float), optional, pointer :: eptr(:), fptr(:), hptr(:)
+
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+ if (associated(ee) .or. associated(ff)) stop 1
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ if (.not.present(ee) .or. .not.present(ff)) stop 1
+ if (associated(ee) .or. associated(ff)) stop 1
+ if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) stop 1
+ 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 1
+ if (associated(eptr) .or. associated(fptr)) stop 1
+ !$omp end target data
+
+ if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 1
+ if (associated(eptr) .or. associated(fptr)) stop 1
+
+ if (allocated(hh)) stop 1
+ !$omp target data map(tofrom:hh) use_device_addr(hh)
+ if (c_associated(c_loc(hh))) stop 1
+ c_hptr = c_loc(hh)
+ hptr => hh
+ if (c_associated(c_hptr)) stop 1
+ if (associated(hptr)) stop 1
+ if (allocated(hh)) stop 1
+ !$omp end target data
+ if (c_associated(c_hptr)) stop 1
+ if (associated(hptr)) stop 1
+ if (allocated(hh)) stop 1
+ 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
+
+ real(c_float), target, allocatable :: cc(:), dd(:)
+ real(c_float), pointer :: ee(:), ff(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+
+ cc = 33.0_c_float
+ dd = 44.0_c_float
+ ee = 55.0_c_float
+ ff = 66.0_c_float
+
+ !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
+ call copy3_array(c_loc(cc), c_loc(dd), N)
+ !$omp end target data
+ if (any(abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+
+ !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
+ call copy3_array(c_loc(ee), c_loc(ff), N)
+ !$omp end target data
+ if (any(abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+
+ deallocate(ee, ff) ! pointers, only
+ end subroutine test_main_1
+
+ ! Save device ptr - and recall pointer
+ subroutine test_main_2
+ integer, parameter :: N = 1000
+
+ real(c_float), target, allocatable :: cc(:), dd(:)
+ real(c_float), pointer :: ee(:), ff(:)
+
+ real(c_float) :: dummy
+ type(c_ptr) :: c_cptr, c_dptr, c_eptr, c_fptr
+ real(c_float), pointer :: cptr(:), dptr(:), eptr(:), fptr(:)
+
+ allocate(cc(N), dd(N), ee(N), ff(N))
+
+ cc = 333.0_c_float
+ dd = 444.0_c_float
+ ee = 555.0_c_float
+ ff = 666.0_c_float
+
+ !$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_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ cc = 3333.0_c_float
+ !$omp target update to(cc)
+ call copy3_array(c_cptr, c_dptr, N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ cc = 33333.0_c_float
+ !$omp target update to(cc)
+ call copy3_array(c_loc(cptr), c_loc(dptr), N)
+ !$omp target update from(dd)
+ if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1
+ !$omp end target data
+
+ if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd))) stop 1
+ if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd))) stop 1
+
+
+ !$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_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+
+ ! check c_loc ptr again after target-value modification
+ ee = 5555.0_c_float
+ !$omp target update to(ee)
+ call copy3_array(c_eptr, c_fptr, N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+
+ ! check Fortran pointer after target-value modification
+ ee = 55555.0_c_float
+ !$omp target update to(ee)
+ call copy3_array(c_loc(eptr), c_loc(fptr), N)
+ !$omp target update from(ff)
+ if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff))) stop 1
+ !$omp end target data
+
+ if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1
+ if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
+
+ deallocate(ee, ff)
+ end subroutine test_main_2
+end module tests
+
+
+program omp_device_addr
+ use tests
+ use test_dummies
+ use test_dummies_opt
+ 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_opt_call_1()
+ call test_dummy_opt_call_2()
+
+ call test_nullptr_1()
+end program omp_device_addr
--- /dev/null
+module target_procs
+ use iso_c_binding
+ implicit none (type, external)
+ private
+ public :: copy3_array, copy3_scalar, copy3_array1, copy3_array3
+contains
+ subroutine copy3_array_int(from_ptr, to_ptr, N)
+ !$omp declare target
+ real(c_double) :: from_ptr(:)
+ real(c_double) :: to_ptr(:)
+ integer, value :: N
+ integer :: i
+
+ !$omp parallel do
+ do i = 1, N
+ to_ptr(i) = 3 * from_ptr(i)
+ end do
+ !$omp end parallel do
+ end subroutine copy3_array_int
+
+ subroutine copy3_scalar_int(from, to)
+ !$omp declare target
+ real(c_double) :: from, to
+
+ to = 3 * from
+ end subroutine copy3_scalar_int
+
+
+ subroutine copy3_array(from, to, N)
+ type(c_ptr), value :: from, to
+ integer, value :: N
+ real(c_double), pointer :: from_ptr(:), to_ptr(:)
+
+ call c_f_pointer(from, from_ptr, shape=[N])
+ call c_f_pointer(to, to_ptr, shape=[N])
+
+ call do_offload_scalar(from_ptr,to_ptr)
+ contains
+ subroutine do_offload_scalar(from_r, to_r)
+ real(c_double), target :: from_r(:), to_r(:)
+ ! The extra function is needed as is_device_ptr
+ ! requires non-value, non-pointer dummy arguments
+
+ !$omp target is_device_ptr(from_r, to_r)
+ call copy3_array_int(from_r, to_r, N)
+ !$omp end target
+ end subroutine do_offload_scalar
+ end subroutine copy3_array
+
+ subroutine copy3_scalar(from, to)
+ type(c_ptr), value, target :: from, to
+ real(c_double), pointer :: from_ptr(:), to_ptr(:)
+
+ ! Standard-conform detour of using an array as at time of writing
+ ! is_device_ptr below does not handle scalars
+ call c_f_pointer(from, from_ptr, shape=[1])
+ call c_f_pointer(to, to_ptr, shape=[1])
+
+ call do_offload_scalar(from_ptr,to_ptr)
+ contains
+ subroutine do_offload_scalar(from_r, to_r)
+ real(c_double), target :: from_r(:), to_r(:)
+ ! The extra function is needed as is_device_ptr
+ ! requires non-value, non-pointer dummy arguments
+
+ !$omp target is_device_ptr(from_r, to_r)
+ call copy3_scalar_int(from_r(1), to_r(1))
+ !$omp end target
+ end subroutine do_offload_scalar
+ end subroutine copy3_scalar
+
+ subroutine copy3_array1(from, to)
+ real(c_double), target :: from(:), to(:)
+ integer :: N
+ N = size(from)
+
+ !!$omp target is_device_ptr(from, to)
+ call copy3_array(c_loc(from), c_loc(to), N)
+ !!$omp end target
+ end subroutine copy3_array1
+
+ subroutine copy3_array3(from, to)
+ real(c_double), optional, target :: from(:), to(:)
+ integer :: N
+ N = size(from)
+
+! !$omp target is_device_ptr(from, to)
+ call copy3_array(c_loc(from), c_loc(to), N)
+! !$omp end target
+ end subroutine copy3_array3
+end module target_procs
+
+
+
+module offloading2
+ use iso_c_binding
+ use target_procs
+ implicit none (type, external)
+contains
+ ! Same as main program but uses dummy *nonoptional* arguments
+ subroutine use_device_ptr_sub(AA, BB, CC, DD, EE, FF, AptrA, BptrB, N)
+ real(c_double), pointer :: AA(:), BB(:)
+ real(c_double), allocatable, target :: CC(:), DD(:)
+ real(c_double), target :: EE(N), FF(N), dummy(1)
+ real(c_double), pointer :: AptrA(:), BptrB(:)
+ intent(inout) :: AA, BB, CC, DD, EE, FF
+ integer, value :: N
+
+ type(c_ptr) :: tgt_aptr, tgt_bptr, tgt_cptr, tgt_dptr, tgt_eptr, tgt_fptr
+
+ AA = 11.0_c_double
+ BB = 22.0_c_double
+ CC = 33.0_c_double
+ DD = 44.0_c_double
+ EE = 55.0_c_double
+ FF = 66.0_c_double
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB)
+ call copy3_array(c_loc(AA), c_loc(BB), N)
+ !$omp end target data
+
+ if (any(abs(AA - 11.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD)
+ call copy3_array(c_loc(CC), c_loc(DD), N)
+ !$omp end target data
+
+ if (any(abs(CC - 33.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF)
+ call copy3_array(c_loc(EE), c_loc(FF), N)
+ !$omp end target data
+
+ if (any(abs(EE - 55.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1
+
+
+
+ AA = 111.0_c_double
+ BB = 222.0_c_double
+ CC = 333.0_c_double
+ DD = 444.0_c_double
+ EE = 555.0_c_double
+ FF = 666.0_c_double
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB)
+ !$omp target data map(alloc:dummy) use_device_ptr(AA,BB)
+ tgt_aptr = c_loc(AA)
+ tgt_bptr = c_loc(BB)
+ AptrA => AA
+ BptrB => BB
+ !$omp end target data
+
+ call copy3_array(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ AA = 1111.0_c_double
+ !$omp target update to(AA)
+ call copy3_array(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ ! AprtA tests
+ AA = 7.0_c_double
+ !$omp target update to(AA)
+ call copy3_array(c_loc(AptrA), c_loc(BptrB), N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ AA = 77.0_c_double
+ !$omp target update to(AA)
+ call copy3_array1(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 77.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+! AA = 777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array2(AptrA, BptrB)
+! !$omp target update from(BB)
+! if (any(abs(AA - 777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ AA = 7777.0_c_double
+ !$omp target update to(AA)
+ call copy3_array3(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+! AA = 77777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array4(AptrA, BptrB)
+! !$omp target update from(BB)
+ !$omp end target data
+!
+! if (any(abs(AA - 77777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD)
+ !$omp target data map(alloc:dummy) use_device_ptr(CC,DD)
+ tgt_cptr = c_loc(CC)
+ tgt_dptr = c_loc(DD)
+ !$omp end target data
+
+ call copy3_array(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1
+
+ CC = 3333.0_c_double
+ !$omp target update to(CC)
+ call copy3_array(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ !$omp end target data
+
+ if (any(abs(CC - 3333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1
+
+
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF)
+ !$omp target data map(alloc:dummy) use_device_ptr(EE,FF)
+ tgt_eptr = c_loc(EE)
+ tgt_fptr = c_loc(FF)
+ !$omp end target data
+
+ call copy3_array(tgt_eptr, tgt_fptr, N)
+ !$omp target update from(FF)
+ if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1
+
+ EE = 5555.0_c_double
+ !$omp target update to(EE)
+ call copy3_array(tgt_eptr, tgt_fptr, N)
+ !$omp target update from(FF)
+ !$omp end target data
+
+ if (any(abs(EE - 5555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1
+ end subroutine use_device_ptr_sub
+
+
+
+ ! Same as main program but uses dummy *optional* arguments
+ subroutine use_device_ptr_sub2(AA, BB, CC, DD, EE, FF, AptrA, BptrB, N)
+ real(c_double), optional, pointer :: AA(:), BB(:)
+ real(c_double), optional, allocatable, target :: CC(:), DD(:)
+ real(c_double), optional, target :: EE(N), FF(N)
+ real(c_double), pointer :: AptrA(:), BptrB(:)
+ intent(inout) :: AA, BB, CC, DD, EE, FF
+ real(c_double), target :: dummy(1)
+ integer, value :: N
+
+ type(c_ptr) :: tgt_aptr, tgt_bptr, tgt_cptr, tgt_dptr, tgt_eptr, tgt_fptr
+
+ AA = 11.0_c_double
+ BB = 22.0_c_double
+ CC = 33.0_c_double
+ DD = 44.0_c_double
+ EE = 55.0_c_double
+ FF = 66.0_c_double
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB)
+ call copy3_array(c_loc(AA), c_loc(BB), N)
+ !$omp end target data
+
+ if (any(abs(AA - 11.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD)
+ call copy3_array(c_loc(CC), c_loc(DD), N)
+ !$omp end target data
+
+ if (any(abs(CC - 33.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF)
+ call copy3_array(c_loc(EE), c_loc(FF), N)
+ !$omp end target data
+
+ if (any(abs(EE - 55.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1
+
+
+
+ AA = 111.0_c_double
+ BB = 222.0_c_double
+ CC = 333.0_c_double
+ DD = 444.0_c_double
+ EE = 555.0_c_double
+ FF = 666.0_c_double
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB)
+ !$omp target data map(alloc:dummy) use_device_ptr(AA,BB)
+ tgt_aptr = c_loc(AA)
+ tgt_bptr = c_loc(BB)
+ AptrA => AA
+ BptrB => BB
+ !$omp end target data
+
+ call copy3_array(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ AA = 1111.0_c_double
+ !$omp target update to(AA)
+ call copy3_array(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ ! AprtA tests
+ AA = 7.0_c_double
+ !$omp target update to(AA)
+ call copy3_array(c_loc(AptrA), c_loc(BptrB), N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ AA = 77.0_c_double
+ !$omp target update to(AA)
+ call copy3_array1(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 77.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+! AA = 777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array2(AptrA, BptrB)
+! !$omp target update from(BB)
+! if (any(abs(AA - 777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ AA = 7777.0_c_double
+ !$omp target update to(AA)
+ call copy3_array3(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+! AA = 77777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array4(AptrA, BptrB)
+! !$omp target update from(BB)
+ !$omp end target data
+!
+! if (any(abs(AA - 77777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD)
+ !$omp target data map(alloc:dummy) use_device_ptr(CC,DD)
+ tgt_cptr = c_loc(CC)
+ tgt_dptr = c_loc(DD)
+ !$omp end target data
+
+ call copy3_array(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1
+
+ CC = 3333.0_c_double
+ !$omp target update to(CC)
+ call copy3_array(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ !$omp end target data
+
+ if (any(abs(CC - 3333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1
+
+
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF)
+ !$omp target data map(alloc:dummy) use_device_ptr(EE,FF)
+ tgt_eptr = c_loc(EE)
+ tgt_fptr = c_loc(FF)
+ !$omp end target data
+
+ call copy3_array(tgt_eptr, tgt_fptr, N)
+ !$omp target update from(FF)
+ if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1
+
+ EE = 5555.0_c_double
+ !$omp target update to(EE)
+ call copy3_array(tgt_eptr, tgt_fptr, N)
+ !$omp end target data
+
+ if (any(abs(EE - 5555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1
+ end subroutine use_device_ptr_sub2
+end module offloading2
+
+
+
+program omp_device_ptr
+ use iso_c_binding
+ use target_procs
+ use offloading2
+ implicit none (type, external)
+
+ integer, parameter :: N = 1000
+ real(c_double), pointer :: AA(:), BB(:), arg_AA(:), arg_BB(:), arg2_AA(:), arg2_BB(:)
+ real(c_double), allocatable, target :: CC(:), DD(:), arg_CC(:), arg_DD(:), arg2_CC(:), arg2_DD(:)
+ real(c_double), target :: EE(N), FF(N), dummy(1), arg_EE(N), arg_FF(N), arg2_EE(N), arg2_FF(N)
+
+ real(c_double), pointer :: AptrA(:), BptrB(:)
+ type(c_ptr) :: tgt_aptr, tgt_bptr, tgt_cptr, tgt_dptr, tgt_eptr, tgt_fptr
+
+ allocate(AA(N), BB(N), CC(N), DD(N))
+
+ AA = 11.0_c_double
+ BB = 22.0_c_double
+ CC = 33.0_c_double
+ DD = 44.0_c_double
+ EE = 55.0_c_double
+ FF = 66.0_c_double
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB)
+ call copy3_array(c_loc(AA), c_loc(BB), N)
+ !$omp end target data
+
+ if (any(abs(AA - 11.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD)
+ call copy3_array(c_loc(CC), c_loc(DD), N)
+ !$omp end target data
+
+ if (any(abs(CC - 33.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF)
+ call copy3_array(c_loc(EE), c_loc(FF), N)
+ !$omp end target data
+
+ if (any(abs(EE - 55.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1
+
+
+
+ AA = 111.0_c_double
+ BB = 222.0_c_double
+ CC = 333.0_c_double
+ DD = 444.0_c_double
+ EE = 555.0_c_double
+ FF = 666.0_c_double
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB)
+ !$omp target data map(alloc:dummy) use_device_ptr(AA,BB)
+ tgt_aptr = c_loc(AA)
+ tgt_bptr = c_loc(BB)
+ AptrA => AA
+ BptrB => BB
+ !$omp end target data
+
+ call copy3_array(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ AA = 1111.0_c_double
+ !$omp target update to(AA)
+ call copy3_array(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ ! AprtA tests
+ AA = 7.0_c_double
+ !$omp target update to(AA)
+ call copy3_array(c_loc(AptrA), c_loc(BptrB), N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ AA = 77.0_c_double
+ !$omp target update to(AA)
+ call copy3_array1(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 77.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+! AA = 777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array2(AptrA, BptrB)
+! !$omp target update from(BB)
+! if (any(abs(AA - 777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+ AA = 7777.0_c_double
+ !$omp target update to(AA)
+ call copy3_array3(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+! AA = 77777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array4(AptrA, BptrB)
+! !$omp target update from(BB)
+ !$omp end target data
+!
+! if (any(abs(AA - 77777.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1
+
+
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD)
+ !$omp target data map(alloc:dummy) use_device_ptr(CC,DD)
+ tgt_cptr = c_loc(CC)
+ tgt_dptr = c_loc(DD)
+ !$omp end target data
+
+ call copy3_array(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1
+
+ CC = 3333.0_c_double
+ !$omp target update to(CC)
+ call copy3_array(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ !$omp end target data
+
+ if (any(abs(CC - 3333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1
+
+
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF)
+ !$omp target data map(alloc:dummy) use_device_ptr(EE,FF)
+ tgt_eptr = c_loc(EE)
+ tgt_fptr = c_loc(FF)
+ !$omp end target data
+
+ call copy3_array(tgt_eptr, tgt_fptr, N)
+ !$omp target update from(FF)
+ if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1
+
+ EE = 5555.0_c_double
+ !$omp target update to(EE)
+ call copy3_array(tgt_eptr, tgt_fptr, N)
+ !$omp target update from(FF)
+ !$omp end target data
+
+ if (any(abs(EE - 5555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1
+
+
+
+ deallocate(AA, BB) ! Free pointers only
+
+ AptrA => null()
+ BptrB => null()
+ allocate(arg_AA(N), arg_BB(N), arg_CC(N), arg_DD(N))
+ call use_device_ptr_sub(arg_AA, arg_BB, arg_CC, arg_DD, arg_EE, arg_FF, AptrA, BptrB, N)
+ deallocate(arg_AA, arg_BB)
+
+ AptrA => null()
+ BptrB => null()
+ allocate(arg2_AA(N), arg2_BB(N), arg2_CC(N), arg2_DD(N))
+ call use_device_ptr_sub2(arg2_AA, arg2_BB, arg2_CC, arg2_DD, arg2_EE, arg2_FF, AptrA, BptrB, N)
+ deallocate(arg2_AA, arg2_BB)
+end program omp_device_ptr
projects / gcc.git / commitdiff