mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-11-28 06:14:10 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

OpenMP] use_device_addr/use_device_ptr with Fortran allocatable/pointer arrays

Browse Source 
gcc/fortran/
        * f95-lang.c (LANG_HOOKS_OMP_ARRAY_DATA): Set to gfc_omp_array_data.
        * trans-array.c (gfc_conv_descriptor_data_get): Handle also
        REFERENCE_TYPE.
        * trans-openmp.c (gfc_omp_array_data): New.
        * trans.h (gfc_omp_array_data): New prototype.

        gcc/
        * hooks.c (hook_tree_tree_bool_null): New.
        * hooks.h (hook_tree_tree_bool_null): Declare.
        * langhooks-def.h (LANG_HOOKS_OMP_ARRAY_DATA): Define.
        (LANG_HOOKS_DECLS): Add it.
        * langhooks.h (lang_hooks_for_decls): Add omp_array_data.
        * omp-low.c (install_var_field): New mode for Fortran descriptor arrays.
        (lower_omp_target): Handle Fortran array with descriptor in
        OMP_CLAUSE_USE_DEVICE_ADDR/OMP_CLAUSE_USE_DEVICE_PTR.

        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.

From-SVN: r277705
This commit is contained in:
Tobias Burnus 2019-11-01 07:59:23 +00:00 committed by Tobias Burnus
parent 271da73284
commit 92e63bd2df
17 changed files with 2354 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/ChangeLog
View File

@ -1,3 +1,14 @@
2019-11-01 Tobias Burnus <tobias@codesourcery.com>
* hooks.c (hook_tree_tree_bool_null): New.
* hooks.h (hook_tree_tree_bool_null): Declare.
* langhooks-def.h (LANG_HOOKS_OMP_ARRAY_DATA): Define.
(LANG_HOOKS_DECLS): Add it.
* langhooks.h (lang_hooks_for_decls): Add omp_array_data.
* omp-low.c (install_var_field): New mode for Fortran descriptor arrays.
(lower_omp_target): Handle Fortran array with descriptor in
OMP_CLAUSE_USE_DEVICE_ADDR/OMP_CLAUSE_USE_DEVICE_PTR.
2019-10-31 Richard Sandiford <richard.sandiford@arm.com>
* config/aarch64/aarch64-sve-builtins.cc (register_builtin_types):

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2019-11-01 Tobias Burnus <tobias@codesourcery.com>
* f95-lang.c (LANG_HOOKS_OMP_ARRAY_DATA): Set to gfc_omp_array_data.
* trans-array.c (gfc_conv_descriptor_data_get): Handle also
REFERENCE_TYPE.
* trans-openmp.c (gfc_omp_array_data): New.
* trans.h (gfc_omp_array_data): New prototype.
2019-10-31 Tobias Burnus <tobias@codesourcery.com>
PR fortran/92284.

2
gcc/fortran/f95-lang.c
View File

@ -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

3
gcc/fortran/trans-array.c
View File

@ -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);

27
gcc/fortran/trans-openmp.c
View File

@ -71,6 +71,33 @@ 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. With type_only = true, it returns the
TREE_TYPE without creating a new tree. */
tree
gfc_omp_array_data (tree decl, bool type_only)
{
tree type = TREE_TYPE (decl);
if (POINTER_TYPE_P (type))
type = TREE_TYPE (type);
if (!GFC_DESCRIPTOR_TYPE_P (type))
return NULL_TREE;
if (type_only)
return GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
if (POINTER_TYPE_P (TREE_TYPE (decl)))
decl = build_fold_indirect_ref (decl);
decl = gfc_conv_descriptor_data_get (decl);
STRIP_NOPS (decl);
return decl;
}
/* True if OpenMP should privatize what this DECL points to rather
than the DECL itself. */

1
gcc/fortran/trans.h
View File

@ -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);
bool gfc_omp_privatize_by_reference (const_tree);
enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree);
tree gfc_omp_report_decl (tree);

6
gcc/hooks.c
View File

@ -429,6 +429,12 @@ hook_tree_tree_int_treep_bool_null (tree, int, tree *, bool)
return NULL;
}
tree
hook_tree_tree_bool_null (tree, bool)
{
return NULL;
}
tree
hook_tree_tree_tree_null (tree, tree)
{

1
gcc/hooks.h
View File

@ -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_bool_null (tree, bool);
extern tree hook_tree_tree_tree_null (tree, tree);
extern tree hook_tree_tree_tree_tree_null (tree, tree, tree);
extern tree hook_tree_tree_int_treep_bool_null (tree, int, tree *, bool);

2
gcc/langhooks-def.h
View File

@ -239,6 +239,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_bool_null
#define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR hook_bool_const_tree_false
#define LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT hook_bool_const_tree_false
#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE hook_bool_const_tree_false
@ -266,6 +267,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, \

5
gcc/langhooks.h
View File

@ -226,6 +226,11 @@ 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 the actual data of an array descriptor - or NULL_TREE
if original tree is not an array descriptor. If the the second argument
is true, only the TREE_TYPE is returned without generating a new tree. */
tree (*omp_array_data) (tree, bool);
/* True if OpenMP should regard this DECL as being a scalar which has Fortran's
allocatable or pointer attribute. */
bool (*omp_is_allocatable_or_ptr) (const_tree);

87
gcc/omp-low.c
View File

@ -715,6 +715,11 @@ 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 & 16) != 0)
{
key = (splay_tree_key) &DECL_NAME (var);
gcc_checking_assert (key != (splay_tree_key) var);
}
if ((mask & 8) != 0)
{
key = (splay_tree_key) &DECL_UID (var);
@ -728,6 +733,9 @@ install_var_field (tree var, bool by_ref, int mask, omp_context *ctx)
|| !is_gimple_omp_oacc (ctx->stmt));
type = TREE_TYPE (var);
if ((mask & 16) != 0)
type = lang_hooks.decls.omp_array_data (var, true);
/* Prevent redeclaring the var in the split-off function with a restrict
pointer type. Note that we only clear type itself, restrict qualifiers in
the pointed-to type will be ignored by points-to analysis. */
@ -752,7 +760,7 @@ install_var_field (tree var, bool by_ref, int mask, omp_context *ctx)
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);
@ -1240,10 +1248,14 @@ 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)
/* Fortran array descriptors. */
if (lang_hooks.decls.omp_array_data (decl, true))
install_var_field (decl, false, 19, ctx);
else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
&& !omp_is_reference (decl)
&& !omp_is_allocatable_or_ptr (decl))
|| TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
install_var_field (decl, true, 11, ctx);
else
install_var_field (decl, false, 11, ctx);
@ -11485,7 +11497,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, true))
|| TREE_CODE (TREE_TYPE (var)) == ARRAY_TYPE)
{
tree new_var = lookup_decl (var, ctx);
@ -11866,7 +11879,14 @@ 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)
if (lang_hooks.decls.omp_array_data (ovar, true))
{
tkind = (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR
? GOMP_MAP_USE_DEVICE_PTR : GOMP_MAP_FIRSTPRIVATE_INT);
x = build_sender_ref ((splay_tree_key) &DECL_NAME (ovar), ctx);
}
else if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR)
{
tkind = GOMP_MAP_USE_DEVICE_PTR;
x = build_sender_ref ((splay_tree_key) &DECL_UID (ovar), ctx);
@ -11877,10 +11897,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 (lang_hooks.decls.omp_array_data (ovar, true))
var = lang_hooks.decls.omp_array_data (ovar, false);
else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
&& !omp_is_reference (ovar)
&& !omp_is_allocatable_or_ptr (ovar))
|| TREE_CODE (type) == ARRAY_TYPE)
var = build_fold_addr_expr (var);
else
{
@ -12048,11 +12070,50 @@ 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);
bool is_array_data;
is_array_data = lang_hooks.decls.omp_array_data (var, true) != NULL;
if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR)
x = build_sender_ref ((splay_tree_key) &DECL_UID (var), ctx);
x = build_sender_ref (is_array_data
? (splay_tree_key) &DECL_NAME (var)
: (splay_tree_key) &DECL_UID (var), ctx);
else
x = build_receiver_ref (var, false, ctx);
if (is_variable_sized (var))
if (is_array_data)
{
bool is_ref = omp_is_reference (var);
/* First, we copy the descriptor data from the host; then
we update its data to point to the target address. */
tree new_var = lookup_decl (var, ctx);
new_var = DECL_VALUE_EXPR (new_var);
tree v = new_var;
if (is_ref)
{
var = build_fold_indirect_ref (var);
gimplify_expr (&var, &new_body, NULL, is_gimple_val,
fb_rvalue);
v = create_tmp_var_raw (TREE_TYPE (var), get_name (var));
gimple_add_tmp_var (v);
TREE_ADDRESSABLE (v) = 1;
gimple_seq_add_stmt (&new_body,
gimple_build_assign (v, var));
tree rhs = build_fold_addr_expr (v);
gimple_seq_add_stmt (&new_body,
gimple_build_assign (new_var, rhs));
}
else
gimple_seq_add_stmt (&new_body,
gimple_build_assign (new_var, var));
tree v2 = lang_hooks.decls.omp_array_data (unshare_expr (v), false);
gcc_assert (v2);
gimplify_expr (&x, &new_body, NULL, is_gimple_val, fb_rvalue);
gimple_seq_add_stmt (&new_body,
gimple_build_assign (v2, x));
}
else if (is_variable_sized (var))
{
tree pvar = DECL_VALUE_EXPR (var);
gcc_assert (TREE_CODE (pvar) == INDIRECT_REF);

9
libgomp/ChangeLog
View File

@ -1,3 +1,12 @@
2019-11-01 Tobias Burnus <tobias@codesourcery.com>
* testsuite/libgomp.fortran/use_device_addr-1.f90 (test_nullptr_1,
test_dummy_opt_nullptr_callee_1): Add present but unallocated test.
* testsuite/libgomp.fortran/use_device_addr-2.f90: Likewise.
* testsuite/libgomp.fortran/use_device_addr-3.f90: New.
* testsuite/libgomp.fortran/use_device_addr-4.f90: New.
* testsuite/testsuite/libgomp.fortran/use_device_ptr-1.f90: New.
2019-10-30 Tobias Burnus <tobias@codesourcery.com>
* testsuite/libgomp.fortran/target9.f90: New.

48
libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90
View File

@ -884,8 +884,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()
@ -905,15 +907,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
@ -932,6 +948,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

48
libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90
View File

@ -884,8 +884,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()
@ -905,15 +907,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
@ -932,6 +948,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

763
libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90 Normal file
View File

@ -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

763
libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90 Normal file
View File

@ -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

595
libgomp/testsuite/libgomp.fortran/use_device_ptr-1.f90 Normal file
View File

@ -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