gfc_fatal_error ("Maximum subrecord length cannot exceed %d",
MAX_SUBRECORD_LENGTH);
+ /* For now, we always want to debug auxiliary variables we create
+ for shared coarrays. */
+ if (flag_coarray == GFC_FCOARRAY_SHARED)
+ flag_debug_aux_vars = 1;
+
gfc_cpp_post_options ();
if (gfc_option.allow_std & GFC_STD_F2008)
if (ref->type == REF_ARRAY && ref->next == NULL)
{
if (ref->u.ar.dimen == 0
- && ref->u.ar.as && ref->u.ar.as->corank)
+ && ref->u.ar.as && ref->u.ar.as->corank
+ && flag_coarray != GFC_FCOARRAY_SHARED)
return result;
ref->u.ar.type = AR_FULL;
for (i = 0; i < ref->u.ar.dimen; i++)
- ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
-
+ {
+ gfc_free_expr (ref->u.ar.start[i]);
+ gfc_free_expr (ref->u.ar.end[i]);
+ gfc_free_expr (ref->u.ar.stride[i]);
+ ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+ }
break;
}
+ if (flag_coarray == GFC_FCOARRAY_SHARED)
+ {
+ for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+ {
+ gfc_free_expr (ref->u.ar.start[i]);
+ gfc_free_expr (ref->u.ar.end[i]);
+ gfc_free_expr (ref->u.ar.stride[i]);
+ ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL;
+ ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
+ }
+ }
+
gfc_free_shape (&result->shape, result->rank);
/* Recalculate rank, shape, etc. */
gfc_add_loop_ss_code (nested_loop, nested_loop->ss, subscript, where);
}
+/* Add stride from rank beg to end - 1. */
+
+static tree
+cas_add_strides (tree expr, tree desc, int beg, int end)
+{
+ int i;
+ tree tmp, stride, lbound;
+ tmp = gfc_index_zero_node;
+ for (i = beg; i < end; i++)
+ {
+ stride = gfc_conv_array_stride (desc, i);
+ lbound = gfc_conv_array_lbound (desc, i);
+ tmp =
+ fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(tmp), tmp,
+ fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (stride), stride, lbound));
+ }
+ return fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE(expr),
+ expr, tmp);
+}
+
+
/* If the full offset is needed, this function calculates the new offset via
new_offset = offset
+ sum (stride[i]*lbound[i]) over remaining codim. */
static tree
-cas_add_this_image_offset (tree offset, tree desc, gfc_array_ref *ar, bool add_lbound)
+cas_add_this_image_offset (tree offset, tree desc, gfc_array_ref *ar,
+ bool correct_full_offset)
{
tree tmp;
+
/* Calculate the actual offset. */
/* tmp = _gfortran_cas_coarray_this_image (0). */
tmp = build_call_expr_loc (input_location, gfor_fndecl_cas_this_image,
build_int_cst (TREE_TYPE (tmp), 1));
/* tmp = _gfortran_cas_coarray_this_image (0) - 1 + lbound[first_codim] */
- if (add_lbound)
+ if (correct_full_offset)
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (tmp), tmp,
gfc_conv_array_lbound(desc, ar->dimen));
tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
gfc_conv_array_stride (desc, ar->dimen), tmp);
+ if (correct_full_offset)
+ tmp = cas_add_strides (tmp, desc, ar->as->rank + 1,
+ ar->as->rank + ar->as->corank);
+
return fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (offset),
offset, tmp);
}
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+
+program coarray_41
+
+ integer, allocatable :: vec(:)[:,:]
+
+ allocate(vec(10)[2,*], source= 37)
+
+ if (.not. allocated(vec)) error stop
+
+ call foo(vec)
+
+ if (any(vec /= 42)) error stop
+
+ deallocate(vec)
+contains
+
+ subroutine foo(gv)
+
+ integer, allocatable, intent(inout) :: gv(:)[:,:]
+ integer, allocatable :: gvin(:)
+
+ allocate(gvin, mold=gv)
+ gvin = 5
+ gv = gv + gvin
+ end subroutine foo
+
+end program coarray_41
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "2" }
+
+program main
+ implicit none
+ integer, dimension(2) :: ia
+ integer, dimension(3) :: ib
+ integer, dimension(4) :: ic
+ integer :: me
+ integer :: a(2)[77:78,3:*]
+ integer :: b(2)[34:35,2:3,*]
+ integer :: c(2) [-21:-20,2:3,4:5,8:*]
+ character(len=20) :: line1, line2, line3
+ me = this_image()
+ ia = this_image(a)
+ ib = this_image(b)
+ ic = this_image(c)
+ a(:)[ia(1),ia(2)] = me
+ b(:)[ib(1),ib(2),ib(3)] = me + 100
+ c(:)[ic(1),ic(2),ic(3),ic(4)] = me + 200
+! print '(Z16)',loc(c(1)[ic(1),ic(2),ic(3),ic(4)]) - (this_image() - 1)*8
+ write (unit=line1,fmt='(*(I4))') a(:)[ia(1),ia(2)]
+ write (unit=line2,fmt='(*(I4))') a(:)
+ write (unit=line3,fmt='(*(I4))') me, me
+ if (line1 /= line2) stop 1
+ if (line1 /= line3) stop 2
+ write (unit=line1,fmt='(*(I4))') b(:)[ib(1),ib(2),ib(3)]
+ write (unit=line2,fmt='(*(I4))') b(:)
+ write (unit=line3,fmt='(*(I4))') me + 100, me + 100
+ if (line1 /= line2) stop 3
+ if (line1 /= line3) stop 4
+ write (unit=line1,fmt='(*(I4))') c(:)[ic(1),ic(2),ic(3),ic(4)]
+ write (unit=line2,fmt='(*(I4))') c(:)
+ write (unit=line3,fmt='(*(I4))') me + 200, me + 200
+ if (line1 /= line2) stop 5
+ if (line1 /= line3) stop 6
+end program main
+
+
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "2" }
+
+program main
+ implicit none
+ integer, dimension(2) :: ia
+ integer, dimension(3) :: ib
+ integer, dimension(4) :: ic
+ integer :: me
+ integer, allocatable :: a(:)[:,:]
+ integer, allocatable :: b(:)[:,:,:]
+ integer, allocatable :: c(:) [:,:,:,:]
+ character(len=20) :: line1, line2, line3
+ me = this_image()
+ allocate (a(2)[77:78,3:*])
+ allocate (b(2)[34:35,2:3,*])
+ allocate (c(2) [-21:-20,2:3,4:5,8:*])
+ ia = this_image(a)
+ ib = this_image(b)
+ ic = this_image(c)
+ a(:)[ia(1),ia(2)] = me
+ b(:)[ib(1),ib(2),ib(3)] = me + 100
+ c(:)[ic(1),ic(2),ic(3),ic(4)] = me + 200
+ write (unit=line1,fmt='(*(I4))') a(:)[ia(1),ia(2)]
+ write (unit=line2,fmt='(*(I4))') a(:)
+ write (unit=line3,fmt='(*(I4))') me, me
+ if (line1 /= line2) stop 1
+ if (line1 /= line3) stop 2
+ write (unit=line1,fmt='(*(I4))') b(:)[ib(1),ib(2),ib(3)]
+ write (unit=line2,fmt='(*(I4))') b(:)
+ write (unit=line3,fmt='(*(I4))') me + 100, me + 100
+ if (line1 /= line2) stop 3
+ if (line1 /= line3) stop 4
+ write (unit=line1,fmt='(*(I4))') c(:)[ic(1),ic(2),ic(3),ic(4)]
+ write (unit=line2,fmt='(*(I4))') c(:)
+ write (unit=line3,fmt='(*(I4))') me + 200, me + 200
+ if (line1 /= line2) stop 5
+ if (line1 /= line3) stop 6
+end program main
+
+
--- /dev/null
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "2" }
+
+program main
+ implicit none
+ integer, dimension(2) :: ia
+ integer, dimension(3) :: ib
+ integer, dimension(4) :: ic
+ integer :: me
+ integer :: a(2)[77:78,3:*]
+ integer :: b(2)[34:35,2:3,*]
+ integer :: c(2) [-21:-20,2:3,4:5,8:*]
+ character(len=20) :: line1, line2, line3
+ me = this_image()
+ ia = this_image(a)
+ ib = this_image(b)
+ ic = this_image(c)
+ a = me
+ b = me + 100
+ c = me + 200
+ write (unit=line1,fmt='(*(I4))') a(:)[ia(1),ia(2)]
+ write (unit=line2,fmt='(*(I4))') a(:)
+ write (unit=line3,fmt='(*(I4))') me, me
+ if (line1 /= line2) stop 1
+ if (line1 /= line3) stop 2
+ write (unit=line1,fmt='(*(I4))') b(:)[ib(1),ib(2),ib(3)]
+ write (unit=line2,fmt='(*(I4))') b(:)
+ write (unit=line3,fmt='(*(I4))') me + 100, me + 100
+ if (line1 /= line2) stop 3
+ if (line1 /= line3) stop 4
+ write (unit=line1,fmt='(*(I4))') c(:)[ic(1),ic(2),ic(3),ic(4)]
+ write (unit=line2,fmt='(*(I4))') c(:)
+ write (unit=line3,fmt='(*(I4))') me + 200, me + 200
+ if (line1 /= line2) stop 5
+ if (line1 /= line3) stop 6
+end program main
+
+