From 32d8a8da4e1e6120c515932878994514e04c909d Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Thu, 31 Dec 2020 10:40:30 +0100
Subject: [PATCH] Fortran: Fix Explicit cobounds of a procedures parameter not
respected [PR78466]
Explicit cobounds of class array procedure parameters were not taken
into account. Furthermore were different cobounds in distinct
procedure parameter lists mixed up, i.e. the last definition was taken
for all. The bounds are now regenerated when tree's and expr's bounds
do not match.
PR fortran/78466
PR fortran/80774
gcc/fortran/ChangeLog:
* array.cc (gfc_compare_array_spec): Take cotype into account.
* class.cc (gfc_build_class_symbol): Coarrays are also arrays.
* gfortran.h (IS_CLASS_COARRAY_OR_ARRAY): New macro to detect
regular and coarray class arrays.
* interface.cc (compare_components): Take codimension into
account.
* resolve.cc (resolve_symbol): Improve error message.
* simplify.cc (simplify_bound_dim): Remove duplicate.
* trans-array.cc (gfc_trans_array_cobounds): Coarrays are also
arrays.
(gfc_trans_array_bounds): Same.
(gfc_trans_dummy_array_bias): Same.
(get_coarray_as): Get the as having a non-zero codim.
(is_explicit_coarray): Detect explicit coarrays.
(gfc_conv_expr_descriptor): Create a new descriptor for explicit
coarrays.
* trans-decl.cc (gfc_build_qualified_array): Coarrays are also
arrays.
(gfc_build_dummy_array_decl): Same.
(gfc_get_symbol_decl): Same.
(gfc_trans_deferred_vars): Same.
* trans-expr.cc (class_scalar_coarray_to_class): Get the
descriptor from the correct location.
(gfc_conv_variable): Pick up the descriptor when needed.
* trans-types.cc (gfc_is_nodesc_array): Coarrays are also
arrays.
(gfc_get_nodesc_array_type): Indentation fix only.
(cobounds_match_decl): Match a tree's bounds to the expr's
bounds and return true, when they match.
(gfc_get_derived_type): Create a new type tree/descriptor, when
the cobounds of the existing declaration and expr to not
match. This happends for class arrays in parameter list, when
there are different cobound declarations.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/poly_run_1.f90: Activate old test code.
* gfortran.dg/coarray/poly_run_2.f90: Activate test. It was
stopping before and passing without an error.
---
gcc/fortran/array.cc | 3 +
gcc/fortran/class.cc | 8 +-
gcc/fortran/gfortran.h | 5 ++
gcc/fortran/interface.cc | 7 ++
gcc/fortran/resolve.cc | 3 +-
gcc/fortran/simplify.cc | 2 -
gcc/fortran/trans-array.cc | 53 ++++++++++++-
gcc/fortran/trans-decl.cc | 20 ++---
gcc/fortran/trans-expr.cc | 34 ++++++---
gcc/fortran/trans-types.cc | 74 ++++++++++++++++---
.../gfortran.dg/coarray/poly_run_1.f90 | 33 ++++-----
.../gfortran.dg/coarray/poly_run_2.f90 | 28 ++++---
12 files changed, 207 insertions(+), 63 deletions(-)
@@ -1017,6 +1017,9 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
if (as1->type != as2->type)
return 0;
+ if (as1->cotype != as2->cotype)
+ return 0;
+
if (as1->type == AS_EXPLICIT)
for (i = 0; i < as1->rank + as1->corank; i++)
{
@@ -709,8 +709,12 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
work on the declared type. All array type other than deferred shape or
assumed rank are added to the function namespace to ensure that they
are properly distinguished. */
- if (attr->dummy && !attr->codimension && (*as)
- && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK))
+ if (attr->dummy && (*as)
+ && ((!attr->codimension
+ && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK))
+ || (attr->codimension
+ && !((*as)->cotype == AS_DEFERRED
+ || (*as)->cotype == AS_ASSUMED_RANK))))
{
char *sname;
ns = gfc_current_ns;
@@ -4043,6 +4043,11 @@ bool gfc_may_be_finalized (gfc_typespec);
&& CLASS_DATA (sym) \
&& CLASS_DATA (sym)->attr.dimension \
&& !CLASS_DATA (sym)->attr.class_pointer)
+#define IS_CLASS_COARRAY_OR_ARRAY(sym) \
+ (sym->ts.type == BT_CLASS && CLASS_DATA (sym) \
+ && (CLASS_DATA (sym)->attr.dimension \
+ || CLASS_DATA (sym)->attr.codimension) \
+ && !CLASS_DATA (sym)->attr.class_pointer)
#define IS_POINTER(sym) \
(sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \
? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer)
@@ -518,12 +518,19 @@ compare_components (gfc_component *cmp1, gfc_component *cmp2,
if (cmp1->attr.dimension != cmp2->attr.dimension)
return false;
+ if (cmp1->attr.codimension != cmp2->attr.codimension)
+ return false;
+
if (cmp1->attr.allocatable != cmp2->attr.allocatable)
return false;
if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
return false;
+ if (cmp1->attr.codimension
+ && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
+ return false;
+
if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER)
{
gfc_charlen *l1 = cmp1->ts.u.cl;
@@ -16909,7 +16909,8 @@ resolve_symbol (gfc_symbol *sym)
&& !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
{
gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
- "deferred shape", sym->name, &sym->declared_at);
+ "deferred shape without allocatable", sym->name,
+ &sym->declared_at);
return;
}
else if (class_attr.codimension && class_attr.allocatable && as
@@ -4115,8 +4115,6 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
goto returnNull;
}
- result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
-
/* Then, we need to know the extent of the given dimension. */
if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
{
@@ -6838,7 +6838,7 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
gfc_se se;
gfc_array_spec *as;
- as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
+ as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
for (dim = as->rank; dim < as->rank + as->corank; dim++)
{
@@ -6887,7 +6887,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
int dim;
- as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
+ as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
size = gfc_index_one_node;
offset = gfc_index_zero_node;
@@ -7230,7 +7230,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
int no_repack;
bool optional_arg;
gfc_array_spec *as;
- bool is_classarray = IS_CLASS_ARRAY (sym);
+ bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
/* Do nothing for pointer and allocatable arrays. */
if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
@@ -7906,6 +7906,51 @@ walk_coarray (gfc_expr *e)
return ss;
}
+gfc_array_spec *
+get_coarray_as (const gfc_expr *e)
+{
+ gfc_array_spec *as;
+ gfc_symbol *sym = e->symtree->n.sym;
+ gfc_component *comp;
+
+ if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
+ as = CLASS_DATA (sym)->as;
+ else if (sym->attr.codimension)
+ as = sym->as;
+ else
+ as = nullptr;
+
+ for (gfc_ref *ref = e->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ comp = ref->u.c.component;
+ if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
+ as = CLASS_DATA (comp)->as;
+ else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
+ as = comp->as;
+ break;
+
+ case REF_ARRAY:
+ case REF_SUBSTRING:
+ case REF_INQUIRY:
+ break;
+ }
+ }
+
+ return as;
+}
+
+bool
+is_explicit_coarray (gfc_expr *expr)
+{
+ if (!gfc_is_coarray (expr))
+ return false;
+
+ gfc_array_spec *cas = get_coarray_as (expr);
+ return cas && cas->cotype == AS_EXPLICIT;
+}
/* Convert an array for passing as an actual argument. Expressions and
vector subscripts are evaluated and stored in a temporary, which is then
@@ -8020,6 +8065,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (need_tmp)
full = 0;
+ else if (is_explicit_coarray (expr))
+ full = 0;
else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
{
/* Create a new descriptor if the array doesn't have one. */
@@ -1016,7 +1016,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
gfc_namespace* procns;
symbol_attribute *array_attr;
gfc_array_spec *as;
- bool is_classarray = IS_CLASS_ARRAY (sym);
+ bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
type = TREE_TYPE (decl);
array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
@@ -1134,7 +1134,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
}
- if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
+ if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE && as->rank != 0
&& as->type != AS_ASSUMED_SIZE)
{
GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
@@ -1238,7 +1238,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
gfc_packed packed;
int n;
bool known_size;
- bool is_classarray = IS_CLASS_ARRAY (sym);
+ bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
/* Use the array as and attr. */
as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
@@ -1760,7 +1760,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then
responsible to extract it from there, when the descriptor is
desired. */
- if (IS_CLASS_ARRAY (sym)
+ if (IS_CLASS_COARRAY_OR_ARRAY (sym)
&& (!DECL_LANG_SPECIFIC (sym->backend_decl)
|| !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)))
{
@@ -1775,10 +1775,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
gfc_add_assign_aux_vars (sym);
- if (sym->ts.type == BT_CLASS && sym->backend_decl)
- GFC_DECL_CLASS(sym->backend_decl) = 1;
+ if (sym->ts.type == BT_CLASS && sym->backend_decl
+ && !IS_CLASS_COARRAY_OR_ARRAY (sym))
+ GFC_DECL_CLASS (sym->backend_decl) = 1;
- return sym->backend_decl;
+ return sym->backend_decl;
}
if (sym->result == sym && sym->attr.assign
@@ -4889,9 +4890,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
}
else if ((sym->attr.dimension || sym->attr.codimension
- || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)))
+ || (IS_CLASS_COARRAY_OR_ARRAY (sym)
+ && !CLASS_DATA (sym)->attr.allocatable)))
{
- bool is_classarray = IS_CLASS_ARRAY (sym);
+ bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
symbol_attribute *array_attr;
gfc_array_spec *as;
array_type type_of_array;
@@ -1018,7 +1018,10 @@ class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
ctree = gfc_class_data_get (var);
- tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
+ tmp = gfc_conv_descriptor_data_get (
+ gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
+ ? tmp
+ : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
/* Pass the address of the class object. */
@@ -3125,7 +3128,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
bool first_time = true;
sym = expr->symtree->n.sym;
- is_classarray = IS_CLASS_ARRAY (sym);
+ is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
ss = se->ss;
if (ss != NULL)
{
@@ -3216,11 +3219,24 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
if (sym->ts.type == BT_CLASS
&& sym->attr.class_ok
&& sym->ts.u.derived->attr.is_class)
- se->class_container = se->expr;
+ {
+ if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
+ && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
+ se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
+ else
+ se->class_container = se->expr;
+ }
/* Dereference the expression, where needed. */
- se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
- is_classarray);
+ if (se->class_container && CLASS_DATA (sym)->attr.codimension
+ && !CLASS_DATA (sym)->attr.dimension)
+ se->expr
+ = gfc_maybe_dereference_var (sym, se->class_container,
+ se->descriptor_only, is_classarray);
+ else
+ se->expr
+ = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
+ is_classarray);
ref = expr->ref;
}
@@ -3263,11 +3279,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
case REF_COMPONENT:
ts = &ref->u.c.component->ts;
- if (first_time && is_classarray && sym->attr.dummy
- && se->descriptor_only
- && !CLASS_DATA (sym)->attr.allocatable
- && !CLASS_DATA (sym)->attr.class_pointer
- && CLASS_DATA (sym)->as
+ if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
+ && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
+ && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
&& CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
&& strcmp ("_data", ref->u.c.component->name) == 0)
/* Skip the first ref of a _data component, because for class
@@ -1381,7 +1381,7 @@ gfc_is_nodesc_array (gfc_symbol * sym)
{
symbol_attribute *array_attr;
gfc_array_spec *as;
- bool is_classarray = IS_CLASS_ARRAY (sym);
+ bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
@@ -1752,7 +1752,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
else
tmp = NULL_TREE;
if (n < as->rank + as->corank - 1)
- GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+ GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
}
if (known_offset)
@@ -2584,6 +2584,53 @@ gfc_get_union_type (gfc_symbol *un)
return typenode;
}
+bool
+cobounds_match_decl (const gfc_symbol *derived)
+{
+ tree arrtype, tmp;
+ gfc_array_spec *as;
+
+ if (!derived->backend_decl)
+ return false;
+ /* Care only about coarray declarations. Everything else is ok with us. */
+ if (!derived->components || strcmp (derived->components->name, "_data") != 0)
+ return true;
+ if (!derived->components->attr.codimension)
+ return true;
+
+ arrtype = TREE_TYPE (TYPE_FIELDS (derived->backend_decl));
+ as = derived->components->as;
+ if (GFC_TYPE_ARRAY_CORANK (arrtype) != as->corank)
+ return false;
+
+ for (int dim = as->rank; dim < as->rank + as->corank; ++dim)
+ {
+ /* Check lower bound. */
+ tmp = TYPE_LANG_SPECIFIC (arrtype)->lbound[dim];
+ if (!tmp || !INTEGER_CST_P (tmp))
+ return false;
+ if (as->lower[dim]->expr_type != EXPR_CONSTANT
+ || as->lower[dim]->ts.type != BT_INTEGER)
+ return false;
+ if (*tmp->int_cst.val != mpz_get_si (as->lower[dim]->value.integer))
+ return false;
+
+ /* Check upper bound. */
+ tmp = TYPE_LANG_SPECIFIC (arrtype)->ubound[dim];
+ if (!tmp && !as->upper[dim])
+ continue;
+
+ if (!tmp || !INTEGER_CST_P (tmp))
+ return false;
+ if (as->upper[dim]->expr_type != EXPR_CONSTANT
+ || as->upper[dim]->ts.type != BT_INTEGER)
+ return false;
+ if (*tmp->int_cst.val != mpz_get_si (as->upper[dim]->value.integer))
+ return false;
+ }
+
+ return true;
+}
/* Build a tree node for a derived type. If there are equal
derived types, with different local names, these are built
@@ -2601,10 +2648,15 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
gfc_component *c;
gfc_namespace *ns;
tree tmp;
- bool coarray_flag;
+ bool coarray_flag, class_coarray_flag;
coarray_flag = flag_coarray == GFC_FCOARRAY_LIB
&& derived->module && !derived->attr.vtype;
+ class_coarray_flag = derived->components
+ && derived->components->ts.type == BT_DERIVED
+ && strcmp (derived->components->name, "_data") == 0
+ && derived->components->attr.codimension
+ && derived->components->as->cotype == AS_EXPLICIT;
gcc_assert (!derived->attr.pdt_template);
@@ -2693,13 +2745,14 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
- if (derived->backend_decl)
+ if (derived->backend_decl
+ && (!class_coarray_flag || cobounds_match_decl (derived)))
{
/* Its components' backend_decl have been built or we are
seeing recursion through the formal arglist of a procedure
pointer component. */
if (TYPE_FIELDS (derived->backend_decl))
- return derived->backend_decl;
+ return derived->backend_decl;
else if (derived->attr.abstract
&& derived->attr.proc_pointer_comp)
{
@@ -2781,7 +2834,7 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
}
}
- if (TYPE_FIELDS (derived->backend_decl))
+ if (!class_coarray_flag && TYPE_FIELDS (derived->backend_decl))
return derived->backend_decl;
/* Build the type member list. Install the newly created RECORD_TYPE
@@ -2888,12 +2941,13 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
DECL_PACKED (field) |= TYPE_PACKED (typenode);
gcc_assert (field);
- if (!c->backend_decl)
+ /* Overwrite for class array to supply different bounds for different
+ types. */
+ if (class_coarray_flag || !c->backend_decl)
c->backend_decl = field;
- if (c->attr.pointer && c->attr.dimension
- && !(c->ts.type == BT_DERIVED
- && strcmp (c->name, "_data") == 0))
+ if (c->attr.pointer && (c->attr.dimension || c->attr.codimension)
+ && !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0))
GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
}
@@ -14,7 +14,7 @@ else
end if
if (allocated(A)) i = 5
call s(A)
-!call st(A) ! FIXME
+call st(A) ! FIXME
contains
@@ -30,22 +30,21 @@ end subroutine s
subroutine st(x)
class(t) :: x(:)[4,2:*]
-! FIXME
-! if (any (lcobound(x) /= [1, 2])) STOP 7
-! if (lcobound(x, dim=1) /= 1) STOP 8
-! if (lcobound(x, dim=2) /= 2) STOP 9
-! if (this_image() == 1) then
-! if (any (this_image(x) /= lcobound(x))) STOP 10
-! if (this_image(x, dim=1) /= lcobound(x, dim=1)) STOP 11
-! if (this_image(x, dim=2) /= lcobound(x, dim=2)) STOP 12
-! end if
-! if (num_images() == 1) then
-! if (any (ucobound(x) /= [4, 2])) STOP 13
-! if (ucobound(x, dim=1) /= 4) STOP 14
-! if (ucobound(x, dim=2) /= 2) STOP 15
-! else
-! if (ucobound(x,dim=1) /= 4) STOP 16
-! end if
+ if (any (lcobound(x) /= [1, 2])) STOP 7
+ if (lcobound(x, dim=1) /= 1) STOP 8
+ if (lcobound(x, dim=2) /= 2) STOP 9
+ if (this_image() == 1) then
+ if (any (this_image(x) /= lcobound(x))) STOP 10
+ if (this_image(x, dim=1) /= lcobound(x, dim=1)) STOP 11
+ if (this_image(x, dim=2) /= lcobound(x, dim=2)) STOP 12
+ end if
+ if (num_images() == 1) then
+ if (any (ucobound(x) /= [4, 2])) STOP 13
+ if (ucobound(x, dim=1) /= 4) STOP 14
+ if (ucobound(x, dim=2) /= 2) STOP 15
+ else
+ if (ucobound(x,dim=1) /= 4) STOP 16
+ end if
end subroutine st
end
@@ -6,16 +6,16 @@ type t
end type t
class(t), allocatable :: A[:,:]
allocate (A[1:4,-5:*])
-if (allocated(A)) stop
if (any (lcobound(A) /= [1, -5])) STOP 1
if (num_images() == 1) then
if (any (ucobound(A) /= [4, -5])) STOP 2
else
if (ucobound(A,dim=1) /= 4) STOP 3
end if
-if (allocated(A)) i = 5
+
call s(A)
-call st(A)
+call s2(A)
+call sa(A)
contains
subroutine s(x)
class(t) :: x[4,2:*]
@@ -26,14 +26,24 @@ subroutine s(x)
if (ucobound(x,dim=1) /= 4) STOP 6
end if
end subroutine s
-subroutine st(x)
- class(t) :: x[:,:]
- if (any (lcobound(x) /= [1, -5])) STOP 7
+subroutine s2(x)
+ ! Check that different cobounds are set correctly.
+ class(t) :: x[2:5,7:*]
+ if (any (lcobound(x) /= [2, 7])) STOP 7
+ if (num_images() == 1) then
+ if (any (ucobound(x) /= [5, 7])) STOP 8
+ else
+ if (ucobound(x,dim=1) /= 5) STOP 9
+ end if
+end subroutine s2
+subroutine sa(x)
+ class(t), allocatable :: x[:,:]
+ if (any (lcobound(x) /= [1, -5])) STOP 10
if (num_images() == 1) then
- if (any (ucobound(x) /= [4, -5])) STOP 8
+ if (any (ucobound(x) /= [4, -5])) STOP 11
else
- if (ucobound(x,dim=1) /= 4) STOP 9
+ if (ucobound(x,dim=1) /= 4) STOP 12
end if
-end subroutine st
+end subroutine sa
end
--
2.45.2