commit a7e1f0958d38bfda7474fbaf6bb31951351ab66d Author: Julian Brown Date: Thu Aug 30 17:00:58 2018 -0700 Derived types for acc update. 2018-09-03 Cesar Philippidis gcc/fortran/ * openmp.c (gfc_match_omp_variable_list): New allow_derived argument. (gfc_match_omp_map_clause): Update call to gfc_match_omp_variable_list. (gfc_match_omp_clauses): Update calls to gfc_match_omp_map_clause. (gfc_match_oacc_update): Update call to gfc_match_omp_clauses. (resolve_omp_clauses): Permit derived type variables in ACC UPDATE clauses. * trans-openmp.c (gfc_trans_omp_clauses_1): Lower derived type members. gcc/ * gimplify.c (gimplify_scan_omp_clauses): Update handling of ACC UPDATE variables. gcc/testsuite/ * gfortran.dg/goacc/derived-types.f90: New test. libgomp/ * testsuite/libgomp.oacc-fortran/update-2.f90: New test. * testsuite/libgomp.oacc-fortran/derived-type-1.f90: New test. diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 94a7f7e..80a4c05 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -222,7 +222,8 @@ static match gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, bool allow_common, bool *end_colon = NULL, gfc_omp_namelist ***headp = NULL, - bool allow_sections = false) + bool allow_sections = false, + bool allow_derived = false) { gfc_omp_namelist *head, *tail, *p; locus old_loc, cur_loc; @@ -248,7 +249,8 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list, case MATCH_YES: gfc_expr *expr; expr = NULL; - if (allow_sections && gfc_peek_ascii_char () == '(') + if ((allow_sections && gfc_peek_ascii_char () == '(') + || (allow_derived && gfc_peek_ascii_char () == '%')) { gfc_current_locus = cur_loc; m = gfc_match_variable (&expr, 0); @@ -914,10 +916,12 @@ omp_inv_mask::omp_inv_mask (const omp_mask &m) : omp_mask (m) mapping. */ static bool -gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op) +gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op, + bool allow_derived) { gfc_omp_namelist **head = NULL; - if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true) + if (gfc_match_omp_variable_list ("", list, false, NULL, &head, true, + allow_derived) == MATCH_YES) { gfc_omp_namelist *n; @@ -935,7 +939,7 @@ gfc_match_omp_map_clause (gfc_omp_namelist **list, gfc_omp_map_op map_op) static match gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, bool first = true, bool needs_space = true, - bool openacc = false) + bool openacc = false, bool allow_derived = false) { gfc_omp_clauses *c = gfc_get_omp_clauses (); locus old_loc; @@ -1039,7 +1043,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_COPY) && gfc_match ("copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM)) + OMP_MAP_TOFROM, allow_derived)) continue; if (mask & OMP_CLAUSE_COPYIN) { @@ -1047,7 +1051,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, { if (gfc_match ("copyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO)) + OMP_MAP_TO, allow_derived)) continue; } else if (gfc_match_omp_variable_list ("copyin (", @@ -1058,7 +1062,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("copyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM)) + OMP_MAP_FROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYPRIVATE) && gfc_match_omp_variable_list ("copyprivate (", @@ -1068,7 +1072,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC)) + OMP_MAP_ALLOC, allow_derived)) continue; break; case 'd': @@ -1104,7 +1108,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_DELETE) && gfc_match ("delete ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_RELEASE)) + OMP_MAP_RELEASE, allow_derived)) continue; if ((mask & OMP_CLAUSE_DEPEND) && gfc_match ("depend ( ") == MATCH_YES) @@ -1156,12 +1160,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, && openacc && gfc_match ("device ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_TO)) + OMP_MAP_FORCE_TO, allow_derived)) continue; if ((mask & OMP_CLAUSE_DEVICEPTR) && gfc_match ("deviceptr ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_DEVICEPTR)) + OMP_MAP_FORCE_DEVICEPTR, + allow_derived)) continue; if ((mask & OMP_CLAUSE_DEVICE_RESIDENT) && gfc_match_omp_variable_list @@ -1239,7 +1244,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_HOST_SELF) && gfc_match ("host ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM)) + OMP_MAP_FORCE_FROM, allow_derived)) continue; break; case 'i': @@ -1511,47 +1516,48 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_COPY) && gfc_match ("pcopy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM)) + OMP_MAP_TOFROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match ("pcopyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO)) + OMP_MAP_TO, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("pcopyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM)) + OMP_MAP_FROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("pcreate ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC)) + OMP_MAP_ALLOC, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRESENT) && gfc_match ("present ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_PRESENT)) + OMP_MAP_FORCE_PRESENT, + allow_derived)) continue; if ((mask & OMP_CLAUSE_COPY) && gfc_match ("present_or_copy ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TOFROM)) + OMP_MAP_TOFROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYIN) && gfc_match ("present_or_copyin ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_TO)) + OMP_MAP_TO, allow_derived)) continue; if ((mask & OMP_CLAUSE_COPYOUT) && gfc_match ("present_or_copyout ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FROM)) + OMP_MAP_FROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_CREATE) && gfc_match ("present_or_create ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_ALLOC)) + OMP_MAP_ALLOC, allow_derived)) continue; if ((mask & OMP_CLAUSE_PRIORITY) && c->priority == NULL @@ -1774,7 +1780,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if ((mask & OMP_CLAUSE_HOST_SELF) && gfc_match ("self ( ") == MATCH_YES && gfc_match_omp_map_clause (&c->lists[OMP_LIST_MAP], - OMP_MAP_FORCE_FROM)) + OMP_MAP_FORCE_FROM, allow_derived)) continue; if ((mask & OMP_CLAUSE_SEQ) && !c->seq @@ -2130,7 +2136,7 @@ gfc_match_oacc_update (void) gfc_omp_clauses *c; locus here = gfc_current_locus; - if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true) + if (gfc_match_omp_clauses (&c, OACC_UPDATE_CLAUSES, false, false, true, true) != MATCH_YES) return MATCH_ERROR; @@ -4336,9 +4342,12 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, || n->expr->ref == NULL || n->expr->ref->next || n->expr->ref->type != REF_ARRAY) - gfc_error ("%qs in %s clause at %L is not a proper " - "array section", n->sym->name, name, - &n->where); + { + if (n->sym->ts.type != BT_DERIVED) + gfc_error ("%qs in %s clause at %L is not a proper " + "array section", n->sym->name, name, + &n->where); + } else if (n->expr->ref->u.ar.codimen) gfc_error ("Coarrays not supported in %s clause at %L", name, &n->where); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index f038f4c..95b15e5 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -2108,7 +2108,68 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree decl = gfc_get_symbol_decl (n->sym); if (DECL_P (decl)) TREE_ADDRESSABLE (decl) = 1; - if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) + /* Handle derived-typed members for OpenACC Update. */ + if (n->sym->ts.type == BT_DERIVED + && n->expr != NULL && n->expr->ref != NULL + && (n->expr->ref->next == NULL + || (n->expr->ref->next != NULL + && n->expr->ref->next->type == REF_ARRAY + && n->expr->ref->next->u.ar.type == AR_FULL)) + && (n->expr->ref->type == REF_ARRAY + && n->expr->ref->u.ar.type != AR_SECTION)) + { + gfc_ref *ref = n->expr->ref; + gfc_component *c = ref->u.c.component; + tree field; + tree context; + tree ptr; + tree type; + tree scratch; + + if (c->backend_decl == NULL_TREE + && ref->u.c.sym != NULL) + gfc_get_derived_type (ref->u.c.sym); + + field = c->backend_decl; + gcc_assert (field && TREE_CODE (field) == FIELD_DECL); + context = DECL_FIELD_CONTEXT (field); + + type = TREE_TYPE (decl); + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + + if (context != type) + { + tree f2 = c->norestrict_decl; + if (!f2 || DECL_FIELD_CONTEXT (f2) != type) + for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; + f2 = DECL_CHAIN (f2)) + if (TREE_CODE (f2) == FIELD_DECL + && DECL_NAME (f2) == DECL_NAME (field)) + break; + gcc_assert (f2); + c->norestrict_decl = f2; + field = f2; + } + + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, + decl); + + scratch = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (field), decl, field, + NULL_TREE); + type = TREE_TYPE (scratch); + ptr = gfc_create_var (pvoid_type_node, NULL); + scratch = fold_convert (pvoid_type_node, + build_fold_addr_expr (scratch)); + gfc_add_modify (block, ptr, scratch); + OMP_CLAUSE_SIZE (node) = TYPE_SIZE_UNIT (type); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + } + else if ((n->sym->ts.type == BT_DERIVED && n->expr == NULL) + || (n->expr == NULL + || n->expr->ref->u.ar.type == AR_FULL)) { if (POINTER_TYPE_P (TREE_TYPE (decl)) && (gfc_omp_privatize_by_reference (decl) @@ -2210,13 +2271,27 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, { tree ptr, ptr2; gfc_init_se (&se, NULL); - if (n->expr->ref->u.ar.type == AR_ELEMENT) + if ((n->sym->ts.type == BT_DERIVED + && n->expr->rank == 0) + || (n->sym->ts.type != BT_DERIVED + && n->expr->ref->u.ar.type == AR_ELEMENT)) { gfc_conv_expr_reference (&se, n->expr); gfc_add_block_to_block (block, &se.pre); ptr = se.expr; + tree type = TREE_TYPE (ptr); + if (n->sym->ts.type == BT_DERIVED) + { + tree t = gfc_create_var (build_pointer_type + (void_type_node), + NULL); + ptr = fold_convert (pvoid_type_node, ptr); + gfc_add_modify (block, t, ptr); + ptr = t; + type = TREE_TYPE (type); + } OMP_CLAUSE_SIZE (node) - = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + = TYPE_SIZE_UNIT (type); } else { @@ -2239,6 +2314,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, ptr); OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (ptr); + if (n->sym->ts.type == BT_DERIVED) + goto finalize_map_clause; if (POINTER_TYPE_P (TREE_TYPE (decl)) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) { @@ -2282,6 +2359,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, ptr2 = fold_convert (sizetype, ptr2); OMP_CLAUSE_SIZE (node3) = fold_build2 (MINUS_EXPR, sizetype, ptr, ptr2); + finalize_map_clause:; } switch (n->u.map_op) { diff --git a/gcc/gimplify.c b/gcc/gimplify.c index dbd0f0e..f7f7f52 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -7955,7 +7955,8 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, = splay_tree_lookup (ctx->variables, (splay_tree_key)decl); bool ptr = (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ALWAYS_POINTER); - if (n == NULL || (n->value & GOVD_MAP) == 0) + if ((n == NULL || (n->value & GOVD_MAP) == 0) + && code != OACC_UPDATE) { tree l = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); diff --git a/gcc/testsuite/gfortran.dg/goacc/derived-types.f90 b/gcc/testsuite/gfortran.dg/goacc/derived-types.f90 new file mode 100644 index 0000000..44a3814 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/derived-types.f90 @@ -0,0 +1,77 @@ +! Test ACC UPDATE with derived types. + +module dt + integer, parameter :: n = 10 + type inner + integer :: d(n) + end type inner + type dtype + integer(8) :: a, b, c(n) + type(inner) :: in + end type dtype +end module dt + +program derived_acc + use dt + + implicit none + type(dtype):: var + integer i + !$acc declare create(var) + !$acc declare pcopy(var%a) ! { dg-error "Syntax error in OpenMP" } + + !$acc update host(var) + !$acc update host(var%a) + !$acc update device(var) + !$acc update device(var%a) + !$acc update self(var) + !$acc update self(var%a) + + !$acc enter data copyin(var) + !$acc enter data copyin(var%a) ! { dg-error "Syntax error in OpenMP" } + + !$acc exit data copyout(var) + !$acc exit data copyout(var%a) ! { dg-error "Syntax error in OpenMP" } + + !$acc data copy(var) + !$acc end data + + !$acc data copyout(var%a) ! { dg-error "Syntax error in OpenMP" } + !$acc end data ! { dg-error "Unexpected ..ACC END" } + + !$acc parallel loop pcopyout(var) + do i = 1, 10 + end do + !$acc end parallel loop + + !$acc parallel loop copyout(var%a) ! { dg-error "Syntax error in OpenMP" } + do i = 1, 10 + end do + !$acc end parallel loop ! { dg-error "Unexpected ..ACC END" } + + !$acc parallel pcopy(var) + !$acc end parallel + + !$acc parallel pcopy(var%a) ! { dg-error "Syntax error in OpenMP" } + do i = 1, 10 + end do + !$acc end parallel ! { dg-error "Unexpected ..ACC END" } + + !$acc kernels pcopyin(var) + !$acc end kernels + + !$acc kernels pcopy(var%a) ! { dg-error "Syntax error in OpenMP" } + do i = 1, 10 + end do + !$acc end kernels ! { dg-error "Unexpected ..ACC END" } + + !$acc kernels loop pcopyin(var) + do i = 1, 10 + end do + !$acc end kernels loop + + !$acc kernels loop pcopy(var%a) ! { dg-error "Syntax error in OpenMP" } + do i = 1, 10 + end do + !$acc end kernels loop ! { dg-error "Unexpected ..ACC END" } +end program derived_acc diff --git a/libgomp/testsuite/libgomp.oacc-fortran/derived-type-1.f90 b/libgomp/testsuite/libgomp.oacc-fortran/derived-type-1.f90 new file mode 100644 index 0000000..1ec4784 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/derived-type-1.f90 @@ -0,0 +1,28 @@ +! Test derived types with subarrays + +! { dg-do run } + + implicit none + type dtype + integer :: a, b, c + end type dtype + integer, parameter :: n = 100 + integer i + type (dtype), dimension(n) :: d + + !$acc data copy(d(1:n)) + !$acc parallel loop + do i = 1, n + d(i)%a = i + d(i)%b = i-1 + d(i)%c = i+1 + end do + !$acc end data + + do i = 1, n + if (d(i)%a /= i) call abort + if (d(i)%b /= i-1) call abort + if (d(i)%c /= i+1) call abort + end do +end program + diff --git a/libgomp/testsuite/libgomp.oacc-fortran/update-2.f90 b/libgomp/testsuite/libgomp.oacc-fortran/update-2.f90 new file mode 100644 index 0000000..a37d526 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/update-2.f90 @@ -0,0 +1,284 @@ +! Test ACC UPDATE with derived types. + +! { dg-do run } + +module dt + integer, parameter :: n = 10 + type inner + integer :: d(n) + end type inner + type mytype + integer(8) :: a, b, c(n) + type(inner) :: in + end type mytype +end module dt + +program derived_acc + use dt + + implicit none + integer i, res + type(mytype) :: var + + var%a = 0 + var%b = 1 + var%c(:) = 10 + var%in%d(:) = 100 + + var%c(:) = 10 + + !$acc enter data copyin(var) + + !$acc parallel loop present(var) + do i = 1, 1 + var%a = var%b + end do + !$acc end parallel loop + + !$acc update host(var%a) + + if (var%a /= var%b) call abort + + var%b = 100 + + !$acc update device(var%b) + + !$acc parallel loop present(var) + do i = 1, 1 + var%a = var%b + end do + !$acc end parallel loop + + !$acc update host(var%a) + + if (var%a /= var%b) call abort + + !$acc parallel loop present (var) + do i = 1, n + var%c(i) = i + end do + !$acc end parallel loop + + !$acc update host(var%c) + + var%a = -1 + + do i = 1, n + if (var%c(i) /= i) call abort + var%c(i) = var%a + end do + + !$acc update device(var%a) + !$acc update device(var%c) + + res = 0 + + !$acc parallel loop present(var) reduction(+:res) + do i = 1, n + if (var%c(i) /= var%a) res = res + 1 + end do + + if (res /= 0) call abort + + var%c(:) = 0 + + !$acc update device(var%c) + + !$acc parallel loop present(var) + do i = 5, 5 + var%c(i) = 1 + end do + !$acc end parallel loop + + !$acc update host(var%c(5)) + + do i = 1, n + if (i /= 5 .and. var%c(i) /= 0) call abort + if (i == 5 .and. var%c(i) /= 1) call abort + end do + + !$acc parallel loop present(var) + do i = 1, n + var%in%d = var%a + end do + !$acc end parallel loop + + !$acc update host(var%in%d) + + do i = 1, n + if (var%in%d(i) /= var%a) call abort + end do + + var%c(:) = 0 + + !$acc update device(var%c) + + var%c(:) = -1 + + !$acc parallel loop present(var) + do i = n/2, n + var%c(i) = i + end do + !$acc end parallel loop + + !$acc update host(var%c(n/2:n)) + + do i = 1,n + if (i < n/2 .and. var%c(i) /= -1) call abort + if (i >= n/2 .and. var%c(i) /= i) call abort + end do + + var%in%d(:) = 0 + !$acc update device(var%in%d) + + !$acc parallel loop present(var) + do i = 5, 5 + var%in%d(i) = 1 + end do + !$acc end parallel loop + + !$acc update host(var%in%d(5)) + + do i = 1, n + if (i /= 5 .and. var%in%d(i) /= 0) call abort + if (i == 5 .and. var%in%d(i) /= 1) call abort + end do + + !$acc exit data delete(var) + + call derived_acc_subroutine(var) +end program derived_acc + +subroutine derived_acc_subroutine(var) + use dt + + implicit none + integer i, res + type(mytype) :: var + + var%a = 0 + var%b = 1 + var%c(:) = 10 + var%in%d(:) = 100 + + var%c(:) = 10 + + !$acc enter data copyin(var) + + !$acc parallel loop present(var) + do i = 1, 1 + var%a = var%b + end do + !$acc end parallel loop + + !$acc update host(var%a) + + if (var%a /= var%b) call abort + + var%b = 100 + + !$acc update device(var%b) + + !$acc parallel loop present(var) + do i = 1, 1 + var%a = var%b + end do + !$acc end parallel loop + + !$acc update host(var%a) + + if (var%a /= var%b) call abort + + !$acc parallel loop present (var) + do i = 1, n + var%c(i) = i + end do + !$acc end parallel loop + + !$acc update host(var%c) + + var%a = -1 + + do i = 1, n + if (var%c(i) /= i) call abort + var%c(i) = var%a + end do + + !$acc update device(var%a) + !$acc update device(var%c) + + res = 0 + + !$acc parallel loop present(var) reduction(+:res) + do i = 1, n + if (var%c(i) /= var%a) res = res + 1 + end do + + if (res /= 0) call abort + + var%c(:) = 0 + + !$acc update device(var%c) + + !$acc parallel loop present(var) + do i = 5, 5 + var%c(i) = 1 + end do + !$acc end parallel loop + + !$acc update host(var%c(5)) + + do i = 1, n + if (i /= 5 .and. var%c(i) /= 0) call abort + if (i == 5 .and. var%c(i) /= 1) call abort + end do + + !$acc parallel loop present(var) + do i = 1, n + var%in%d = var%a + end do + !$acc end parallel loop + + !$acc update host(var%in%d) + + do i = 1, n + if (var%in%d(i) /= var%a) call abort + end do + + var%c(:) = 0 + + !$acc update device(var%c) + + var%c(:) = -1 + + !$acc parallel loop present(var) + do i = n/2, n + var%c(i) = i + end do + !$acc end parallel loop + + !$acc update host(var%c(n/2:n)) + + do i = 1,n + if (i < n/2 .and. var%c(i) /= -1) call abort + if (i >= n/2 .and. var%c(i) /= i) call abort + end do + + var%in%d(:) = 0 + !$acc update device(var%in%d) + + !$acc parallel loop present(var) + do i = 5, 5 + var%in%d(i) = 1 + end do + !$acc end parallel loop + + !$acc update host(var%in%d(5)) + + do i = 1, n + if (i /= 5 .and. var%in%d(i) /= 0) call abort + if (i == 5 .and. var%in%d(i) /= 1) call abort + end do + + !$acc exit data delete(var) +end subroutine derived_acc_subroutine