From: Tobias Burnus <tobias@codesourcery.com>
To: gcc-patches <gcc-patches@gcc.gnu.org>,
fortran <fortran@gcc.gnu.org>, Jakub Jelinek <jakub@redhat.com>
Subject: [Patch][OpenMP] use_device_addr/use_device_ptr with Fortran allocatable/pointer arrays (= array descriptor)
Date: Mon, 14 Oct 2019 13:17:00 -0000 [thread overview]
Message-ID: <7b38dcfe-7510-59f1-f6aa-1735abc340c8@codesourcery.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 717 bytes --]
This is a follow-up patch to the use_device_addr work. In particular, it
replaces the patch at https://gcc.gnu.org/ml/fortran/2019-09/msg00088.html
Fortran array descriptors need special handling, which this patch adds.
[The use_device-addr-{3,4} test cases are based on the
use_device_addr-{1,2} ones; I saw that I could have tested there
optional + deallocated in addition, hence, I added it as well (to all
four files). – The use_device-ptr-1.f90 is a slightly cleaned-up version
of previous patch and I have removed the compile-time checks of previous
patch.]
Bootstrapped + regtested on x86_64-gnu-linux w/o "device". And tested
additionally the testcases with nvptx offloading.
Thanks,
Tobias
[-- Attachment #2: use_device_addr_desc.diff --]
[-- Type: text/x-patch, Size: 99846 bytes --]
gcc/fortran/
* f95-lang.c (LANG_HOOKS_OMP_ARRAY_DATA): Set to gfc_omp_array_data.
* trans-array.c
* trans-openmp.c (gfc_omp_array_data): New.
* trans.h (gfc_omp_array_data): New prototype.
gcc/
* hooks.c (hook_tree_tree_null): New.
* hooks.h (hook_tree_tree_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 (omp_context): Add array_data_map.
(delete_omp_context): Free array_data_map.
(install_var_field, scan_sharing_clauses, lower_omp_target):
Handle Fortran descriptor arrays.
libgomp/
* 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.
diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c
index 0f72ab9e3b4..0684c3b99cf 100644
--- a/gcc/fortran/f95-lang.c
+++ b/gcc/fortran/f95-lang.c
@@ -113,6 +113,7 @@ static const struct attribute_spec gfc_attribute_table[] =
#undef LANG_HOOKS_TYPE_FOR_MODE
#undef LANG_HOOKS_TYPE_FOR_SIZE
#undef LANG_HOOKS_INIT_TS
+#undef LANG_HOOKS_OMP_ARRAY_DATA
#undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR
#undef LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT
#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
@@ -147,6 +148,7 @@ static const struct attribute_spec gfc_attribute_table[] =
#define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode
#define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size
#define LANG_HOOKS_INIT_TS gfc_init_ts
+#define LANG_HOOKS_OMP_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
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 437892a6abf..2c4f695ba54 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -142,6 +142,9 @@ gfc_conv_descriptor_data_get (tree desc)
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);
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index dad11a24430..42929217eb8 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -71,6 +71,29 @@ gfc_omp_is_optional_argument (const_tree decl)
&& 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. */
+
+tree
+gfc_omp_array_data (tree decl)
+{
+ tree type = TREE_TYPE (decl);
+
+ if (TREE_CODE (type) == REFERENCE_TYPE || POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+
+ if (!GFC_DESCRIPTOR_TYPE_P (type))
+ return NULL_TREE;
+
+ 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. */
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index e96b22acc68..1da0eb96951 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -788,6 +788,7 @@ bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
/* In trans-openmp.c */
bool gfc_omp_is_allocatable_or_ptr (const_tree);
bool gfc_omp_is_optional_argument (const_tree);
+tree gfc_omp_array_data (tree);
bool gfc_omp_privatize_by_reference (const_tree);
enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree);
tree gfc_omp_report_decl (tree);
diff --git a/gcc/hooks.c b/gcc/hooks.c
index a9a87de3cdb..002c7b216d3 100644
--- a/gcc/hooks.c
+++ b/gcc/hooks.c
@@ -429,6 +429,12 @@ hook_tree_tree_int_treep_bool_null (tree, int, tree *, bool)
return NULL;
}
+tree
+hook_tree_tree_null (tree)
+{
+ return NULL;
+}
+
tree
hook_tree_tree_tree_null (tree, tree)
{
diff --git a/gcc/hooks.h b/gcc/hooks.h
index 7cfe91d12df..2d7afc6f529 100644
--- a/gcc/hooks.h
+++ b/gcc/hooks.h
@@ -106,6 +106,7 @@ extern HOST_WIDE_INT hook_hwi_void_0 (void);
extern tree hook_tree_const_tree_null (const_tree);
extern tree hook_tree_void_null (void);
+extern tree hook_tree_tree_null (tree);
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);
diff --git a/gcc/langhooks-def.h b/gcc/langhooks-def.h
index c5dc83d1cc8..66ac684b74f 100644
--- a/gcc/langhooks-def.h
+++ b/gcc/langhooks-def.h
@@ -236,6 +236,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree);
#define LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL lhd_warn_unused_global_decl
#define LANG_HOOKS_POST_COMPILATION_PARSING_CLEANUPS NULL
#define LANG_HOOKS_DECL_OK_FOR_SIBCALL lhd_decl_ok_for_sibcall
+#define LANG_HOOKS_OMP_ARRAY_DATA hook_tree_tree_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
@@ -263,6 +264,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree);
LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL, \
LANG_HOOKS_POST_COMPILATION_PARSING_CLEANUPS, \
LANG_HOOKS_DECL_OK_FOR_SIBCALL, \
+ LANG_HOOKS_OMP_ARRAY_DATA, \
LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR, \
LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT, \
LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE, \
diff --git a/gcc/langhooks.h b/gcc/langhooks.h
index 97e3186a41d..ddcbca717ce 100644
--- a/gcc/langhooks.h
+++ b/gcc/langhooks.h
@@ -222,6 +222,10 @@ struct lang_hooks_for_decls
/* True if this decl may be called via a sibcall. */
bool (*ok_for_sibcall) (const_tree);
+ /* Return a tree for of the actual data of an array descriptor - or
+ NULL_TREE if original tree is not an array descriptor. */
+ tree (*omp_array_data) (tree);
+
/* True if OpenMP should regard this DECL as being a scalar which has Fortran's
allocatable or pointer attribute. */
bool (*omp_is_allocatable_or_ptr) (const_tree);
diff --git a/gcc/omp-low.c b/gcc/omp-low.c
index 279b6ef893a..f56bf11a7bb 100644
--- a/gcc/omp-low.c
+++ b/gcc/omp-low.c
@@ -90,6 +90,7 @@ struct omp_context
/* Map variables to fields in a structure that allows communication
between sending and receiving threads. */
splay_tree field_map;
+ splay_tree array_data_map;
tree record_type;
tree sender_decl;
tree receiver_decl;
@@ -715,7 +716,9 @@ install_var_field (tree var, bool by_ref, int mask, omp_context *ctx)
tree field, type, sfield = NULL_TREE;
splay_tree_key key = (splay_tree_key) var;
- if ((mask & 8) != 0)
+ if ((mask & 16) != 0)
+ key = (splay_tree_key) var;
+ else if ((mask & 8) != 0)
{
key = (splay_tree_key) &DECL_UID (var);
gcc_checking_assert (key != (splay_tree_key) var);
@@ -745,14 +748,17 @@ install_var_field (tree var, bool by_ref, int mask, omp_context *ctx)
else if ((mask & 3) == 1 && omp_is_reference (var))
type = TREE_TYPE (type);
- field = build_decl (DECL_SOURCE_LOCATION (var),
- FIELD_DECL, DECL_NAME (var), type);
+ if ((mask & 16) != 0)
+ field = build_decl (UNKNOWN_LOCATION, FIELD_DECL, NULL_TREE, type);
+ else
+ field = build_decl (DECL_SOURCE_LOCATION (var),
+ FIELD_DECL, DECL_NAME (var), type);
/* Remember what variable this field was created for. This does have a
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);
@@ -976,6 +982,8 @@ delete_omp_context (splay_tree_value value)
splay_tree_delete (ctx->field_map);
if (ctx->sfield_map)
splay_tree_delete (ctx->sfield_map);
+ if (ctx->array_data_map)
+ splay_tree_delete (ctx->array_data_map);
/* We hijacked DECL_ABSTRACT_ORIGIN earlier. We need to clear it before
it produces corrupt debug information. */
@@ -1070,7 +1078,7 @@ fixup_child_record_type (omp_context *ctx)
static void
scan_sharing_clauses (tree clauses, omp_context *ctx)
{
- tree c, decl;
+ tree c, decl, x;
bool scan_array_reductions = false;
for (c = clauses; c; c = OMP_CLAUSE_CHAIN (c))
@@ -1240,10 +1248,33 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
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)
+ x = NULL;
+ // Handle array descriptors
+ if (TREE_CODE (TREE_TYPE (decl)) == RECORD_TYPE ||
+ (omp_is_reference (decl)
+ && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == RECORD_TYPE))
+ x = lang_hooks.decls.omp_array_data (decl);
+
+ if (x)
+ {
+ gcc_assert (!ctx->array_data_map
+ || !splay_tree_lookup (ctx->array_data_map,
+ (splay_tree_key) decl));
+ if (!ctx->array_data_map)
+ ctx->array_data_map
+ = splay_tree_new (splay_tree_compare_pointers, 0, 0);
+
+ splay_tree_insert (ctx->array_data_map, (splay_tree_key) decl,
+ (splay_tree_value) x);
+
+ install_var_field (x, false, 19, ctx);
+ DECL_SOURCE_LOCATION (lookup_field (x, ctx))
+ = OMP_CLAUSE_LOCATION (c);
+ }
+ 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);
@@ -11485,7 +11516,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *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))
|| TREE_CODE (TREE_TYPE (var)) == ARRAY_TYPE)
{
tree new_var = lookup_decl (var, ctx);
@@ -11866,7 +11898,19 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *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)
+
+ // For arrays with descriptor, use the pointer to the actual data
+ splay_tree_node n = ctx->array_data_map
+ ? splay_tree_lookup (ctx->array_data_map,
+ (splay_tree_key) ovar)
+ : NULL;
+ if (n)
+ {
+ tkind = OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR
+ ? GOMP_MAP_USE_DEVICE_PTR : GOMP_MAP_FIRSTPRIVATE_INT;
+ x = build_sender_ref ((tree) n->value, 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);
@@ -11877,10 +11921,12 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *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 (n)
+ var = (tree) n->value;
+ 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
{
@@ -12048,11 +12094,56 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
case OMP_CLAUSE_USE_DEVICE_ADDR:
case OMP_CLAUSE_IS_DEVICE_PTR:
var = OMP_CLAUSE_DECL (c);
+ tree array_data = NULL;
+ if (ctx->array_data_map)
+ {
+ splay_tree_node n = splay_tree_lookup (ctx->array_data_map,
+ (splay_tree_key) var);
+ if (n)
+ array_data = (tree) n->value;
+ }
+
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 (array_data
+ ? (splay_tree_key) array_data
+ : (splay_tree_key) &DECL_UID (var), ctx);
else
- x = build_receiver_ref (var, false, ctx);
- if (is_variable_sized (var))
+ x = build_receiver_ref (array_data ? array_data : var, false, ctx);
+
+ if (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));
+ 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);
diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90
index 2e5ce60d47c..19da2c5275a 100644
--- a/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90
+++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90
@@ -883,8 +883,10 @@ contains
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()
@@ -904,15 +906,29 @@ contains
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
@@ -931,6 +947,26 @@ contains
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
diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90
index bddb4491414..d4fae6439d5 100644
--- a/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90
+++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90
@@ -883,8 +883,10 @@ contains
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()
@@ -904,15 +906,29 @@ contains
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
@@ -931,6 +947,26 @@ contains
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
diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90
new file mode 100644
index 00000000000..6d794d74cb3
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90
@@ -0,0 +1,763 @@
+! 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
diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90
new file mode 100644
index 00000000000..32dc92c2ff4
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90
@@ -0,0 +1,763 @@
+! 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
diff --git a/libgomp/testsuite/libgomp.fortran/use_device_ptr-1.f90 b/libgomp/testsuite/libgomp.fortran/use_device_ptr-1.f90
new file mode 100644
index 00000000000..62f09682128
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/use_device_ptr-1.f90
@@ -0,0 +1,595 @@
+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
next reply other threads:[~2019-10-14 13:12 UTC|newest]
Thread overview: 6+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-10-14 13:17 Tobias Burnus [this message]
2019-10-23 7:08 ` *ping* " Tobias Burnus
2019-10-30 10:46 ` Jakub Jelinek
2019-10-31 17:10 ` Tobias Burnus
2019-10-31 18:02 ` Jakub Jelinek
2019-11-11 9:16 ` Thomas Schwinge
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=7b38dcfe-7510-59f1-f6aa-1735abc340c8@codesourcery.com \
--to=tobias@codesourcery.com \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
--cc=jakub@redhat.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).