OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/50069 (FORALL fails on a character array) 

2017-01-18  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/50069
	PR fortran/55086
	* gfortran.dg/pr50069_1.f90: New test.
	* gfortran.dg/pr50069_2.f90: New test.
	* gfortran.dg/pr55086_1.f90: New test.
	* gfortran.dg/pr55086_1_tfat.f90: New test.
	* gfortran.dg/pr55086_2.f90: New test.
	* gfortran.dg/pr55086_2_tfat.f90: New test.
	* gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90: New test.

2017-01-18  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/50069
	PR fortran/55086
	* trans-expr.c (gfc_conv_variable): Don't treat temporary variables
	as function arguments.
	* trans-stmt.c (forall_make_variable_temp,
	generate_loop_for_temp_to_lhs, gfc_trans_assign_need_temp,
	gfc_trans_forall_1): Don't adjust offset of forall temporary
	for array sections, make forall temporaries work for substring
	expressions, improve test coverage by adding -ftest-forall-temp
	option to request usage of temporary array in forall code.
	* lang.opt: Add -ftest-forall-temp option.
	* invoke.texi: Add -ftest-forall-temp option.

From-SVN: r244601
This commit is contained in:
Louis Krupp 2017-01-18 21:41:48 +00:00 committed by Louis Krupp
parent b37589b0c4
commit 7bd5dad249
13 changed files with 399 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View File

@ -1,3 +1,18 @@
2017-01-18 Louis Krupp <louis.krupp@zoho.com>
PR fortran/50069
PR fortran/55086
* trans-expr.c (gfc_conv_variable): Don't treat temporary variables
as function arguments.
* trans-stmt.c (forall_make_variable_temp,
generate_loop_for_temp_to_lhs, gfc_trans_assign_need_temp,
gfc_trans_forall_1): Don't adjust offset of forall temporary
for array sections, make forall temporaries work for substring
expressions, improve test coverage by adding -ftest-forall-temp
option to request usage of temporary array in forall code.
* lang.opt: Add -ftest-forall-temp option.
* invoke.texi: Add -ftest-forall-temp option.
2017-01-18 Andre Vehreschild <vehre@gcc.gnu.org>
* primary.c (caf_variable_attr): Improve figuring whether the current

5
gcc/fortran/invoke.texi
View File

@ -124,6 +124,7 @@ by type. Explanations are in the following sections.
-fmax-identifier-length -fmodule-private -ffixed-form -fno-range-check @gol
-fopenacc -fopenmp -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 @gol
-freal-8-real-10 -freal-8-real-16 -freal-8-real-4 -std=@var{std}
-ftest-forall-temp
}
@item Preprocessing Options
@ -459,6 +460,10 @@ allows the Fortran 2008 standard including the additions of the
Technical Specification (TS) 29113 on Further Interoperability of Fortran
with C and TS 18508 on Additional Parallel Features in Fortran.
@item -ftest-forall-temp
@opindex @code{ftest-forall-temp}
Enhance test coverage by forcing most forall assignments to use temporary.
@end table
@node Preprocessing Options

4
gcc/fortran/lang.opt
View File

@ -488,6 +488,10 @@ ffixed-form
Fortran RejectNegative
Assume that the source file is fixed form.
ftest-forall-temp
Fortran Var(flag_test_forall_temp) Init(0)
Force creation of temporary to test infrequently-executed forall code
finteger-4-integer-8
Fortran RejectNegative Var(flag_integer4_kind,8)
Interpret any INTEGER(4) as an INTEGER(8).

6
gcc/fortran/trans-expr.c
View File

@ -2544,8 +2544,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
if (se_expr)
se->expr = se_expr;
/* Procedure actual arguments. */
else if (sym->attr.flavor == FL_PROCEDURE
/* Procedure actual arguments. Look out for temporary variables
with the same attributes as function values. */
else if (!sym->attr.temporary
&& sym->attr.flavor == FL_PROCEDURE
&& se->expr != current_function_decl)
{
if (!sym->attr.dummy && !sym->attr.proc_pointer)

200
gcc/fortran/trans-stmt.c
View File

@ -3196,7 +3196,7 @@ forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
gfc_add_block_to_block (post, &tse.post);
tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
if (e->ts.type != BT_CHARACTER)
if (c->expr1->ref->u.ar.type != AR_SECTION)
{
/* Use the variable offset for the temporary. */
tmp = gfc_conv_array_offset (old_sym->backend_decl);
@ -3526,114 +3526,103 @@ gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
static tree
generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
tree count1, tree wheremask, bool invert)
tree count1,
gfc_ss *lss, gfc_ss *rss,
tree wheremask, bool invert)
{
gfc_ss *lss;
gfc_se lse, rse;
stmtblock_t block, body;
gfc_loopinfo loop1;
stmtblock_t block, body1;
gfc_loopinfo loop;
gfc_se lse;
gfc_se rse;
tree tmp;
tree wheremaskexpr;
/* Walk the lhs. */
lss = gfc_walk_expr (expr);
(void) rss; /* TODO: unused. */
gfc_start_block (&block);
gfc_init_se (&rse, NULL);
gfc_init_se (&lse, NULL);
if (lss == gfc_ss_terminator)
{
gfc_start_block (&block);
gfc_init_se (&lse, NULL);
/* Translate the expression. */
gfc_init_block (&body1);
gfc_conv_expr (&lse, expr);
/* Form the expression for the temporary. */
tmp = gfc_build_array_ref (tmp1, count1, NULL);
/* Use the scalar assignment as is. */
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_modify (&block, lse.expr, tmp);
gfc_add_block_to_block (&block, &lse.post);
/* Increment the count1. */
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
count1, gfc_index_one_node);
gfc_add_modify (&block, count1, tmp);
tmp = gfc_finish_block (&block);
rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
}
else
{
gfc_start_block (&block);
/* Initialize the loop. */
gfc_init_loopinfo (&loop);
gfc_init_loopinfo (&loop1);
gfc_init_se (&rse, NULL);
gfc_init_se (&lse, NULL);
/* We may need LSS to determine the shape of the expression. */
gfc_add_ss_to_loop (&loop, lss);
/* Associate the lss with the loop. */
gfc_add_ss_to_loop (&loop1, lss);
/* Calculate the bounds of the scalarization. */
gfc_conv_ss_startstride (&loop1);
/* Setup the scalarizing loops. */
gfc_conv_loop_setup (&loop1, &expr->where);
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &expr->where);
gfc_mark_ss_chain_used (lss, 1);
/* Start the loop body. */
gfc_start_scalarized_body (&loop, &body1);
/* Start the scalarized loop body. */
gfc_start_scalarized_body (&loop1, &body);
/* Setup the gfc_se structures. */
gfc_copy_loopinfo_to_se (&lse, &loop1);
/* Translate the expression. */
gfc_copy_loopinfo_to_se (&lse, &loop);
lse.ss = lss;
/* Form the expression of the temporary. */
if (lss != gfc_ss_terminator)
rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
/* Translate expr. */
gfc_conv_expr (&lse, expr);
/* Use the scalar assignment. */
rse.string_length = lse.string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, true);
/* Form the expression of the temporary. */
rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
}
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
if (invert)
wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
wheremaskexpr);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
wheremaskexpr, tmp,
build_empty_stmt (input_location));
}
/* Use the scalar assignment. */
rse.string_length = lse.string_length;
tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
expr->expr_type == EXPR_VARIABLE, false);
gfc_add_expr_to_block (&body, tmp);
/* Form the mask expression according to the mask tree list. */
if (wheremask)
{
wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
if (invert)
wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
TREE_TYPE (wheremaskexpr),
wheremaskexpr);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
wheremaskexpr, tmp,
build_empty_stmt (input_location));
}
/* Increment count1. */
tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
count1, gfc_index_one_node);
gfc_add_modify (&body, count1, tmp);
gfc_add_expr_to_block (&body1, tmp);
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
count1, gfc_index_one_node);
gfc_add_modify (&body1, count1, tmp);
if (lss == gfc_ss_terminator)
gfc_add_block_to_block (&block, &body1);
else
{
/* Increment count3. */
if (count3)
{
tmp = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, count3,
gfc_index_one_node);
gfc_add_modify (&body, count3, tmp);
gfc_array_index_type,
count3, gfc_index_one_node);
gfc_add_modify (&body1, count3, tmp);
}
/* Generate the copying loops. */
gfc_trans_scalarizing_loops (&loop1, &body);
gfc_add_block_to_block (&block, &loop1.pre);
gfc_add_block_to_block (&block, &loop1.post);
gfc_cleanup_loop (&loop1);
gfc_trans_scalarizing_loops (&loop, &body1);
tmp = gfc_finish_block (&block);
gfc_add_block_to_block (&block, &loop.pre);
gfc_add_block_to_block (&block, &loop.post);
gfc_cleanup_loop (&loop);
/* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
as tree nodes in SS may not be valid in different scope. */
}
tmp = gfc_finish_block (&block);
return tmp;
}
@ -3989,26 +3978,39 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
/* Calculate the size of temporary needed in the assignment. Return loop, lss
and rss which are used in function generate_loop_for_rhs_to_temp(). */
gfc_init_block (&inner_size_body);
inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
&lss, &rss);
/* The type of LHS. Used in function allocate_temp_for_forall_nest */
if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
if (expr1->ts.type == BT_CHARACTER)
{
if (!expr1->ts.u.cl->backend_decl)
type = NULL;
if (expr1->ref && expr1->ref->type == REF_SUBSTRING)
{
gfc_se tse;
gfc_init_se (&tse, NULL);
gfc_conv_expr (&tse, expr1->ts.u.cl->length);
expr1->ts.u.cl->backend_decl = tse.expr;
gfc_se ssse;
gfc_init_se (&ssse, NULL);
gfc_conv_expr (&ssse, expr1);
type = gfc_get_character_type_len (gfc_default_character_kind,
ssse.string_length);
}
else
{
if (!expr1->ts.u.cl->backend_decl)
{
gfc_se tse;
gcc_assert (expr1->ts.u.cl->length);
gfc_init_se (&tse, NULL);
gfc_conv_expr (&tse, expr1->ts.u.cl->length);
expr1->ts.u.cl->backend_decl = tse.expr;
}
type = gfc_get_character_type_len (gfc_default_character_kind,
expr1->ts.u.cl->backend_decl);
}
type = gfc_get_character_type_len (gfc_default_character_kind,
expr1->ts.u.cl->backend_decl);
}
else
type = gfc_typenode_for_spec (&expr1->ts);
gfc_init_block (&inner_size_body);
inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
&lss, &rss);
/* Allocate temporary for nested forall construct according to the
information in nested_forall_info and inner_size. */
tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
@ -4030,8 +4032,14 @@ gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
if (wheremask)
gfc_add_modify (block, count, gfc_index_zero_node);
/* TODO: Second call to compute_inner_temp_size to initialize lss and
rss; there must be a better way. */
inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
&lss, &rss);
/* Generate codes to copy the temporary to lhs. */
tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
lss, rss,
wheremask, invert);
/* Generate body and loops according to the information in
@ -4488,8 +4496,8 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
/* Temporaries due to array assignment data dependencies introduce
no end of problems. */
if (need_temp)
gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
if (need_temp || flag_test_forall_temp)
gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
nested_forall_info, &block);
else
{
@ -4517,7 +4525,12 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
/* Pointer assignment inside FORALL. */
case EXEC_POINTER_ASSIGN:
need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
if (need_temp)
/* Avoid cases where a temporary would never be needed and where
the temp code is guaranteed to fail. */
if (need_temp
|| (flag_test_forall_temp
&& c->expr2->expr_type != EXPR_CONSTANT
&& c->expr2->expr_type != EXPR_NULL))
gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
nested_forall_info, &block);
else
@ -5125,7 +5138,8 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
if (nested_forall_info != NULL)
{
need_temp = gfc_check_dependency (expr1, expr2, 0);
if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
if ((need_temp || flag_test_forall_temp)
&& cnext->op != EXEC_ASSIGN_CALL)
gfc_trans_assign_need_temp (expr1, expr2,
cmask, invert,
nested_forall_info, block);

12
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,15 @@
2017-01-18 Louis Krupp <louis.krupp@zoho.com>
PR fortran/50069
PR fortran/55086
* gfortran.dg/pr50069_1.f90: New test.
* gfortran.dg/pr50069_2.f90: New test.
* gfortran.dg/pr55086_1.f90: New test.
* gfortran.dg/pr55086_1_tfat.f90: New test.
* gfortran.dg/pr55086_2.f90: New test.
* gfortran.dg/pr55086_2_tfat.f90: New test.
* gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90: New test.
2017-01-18 Aaron Sawdey <acsawdey@linux.vnet.ibm.com>
* gcc.dg/strcmp-1.c: New test.
* gcc.dg/strncmp-1.c: Add test for a bug that escaped.

9
gcc/testsuite/gfortran.dg/pr50069_1.f90 Normal file
View File

@ -0,0 +1,9 @@
! { dg-do run }
implicit none
integer i
character(LEN=6) :: a(1) = "123456"
forall (i = 3:4) a(1)(i:i+2) = a(1)(i-2:i)
!print *,a ! displays '12@' must be '121234'
IF (a(1) .ne. "121234") call abort
end

11
gcc/testsuite/gfortran.dg/pr50069_2.f90 Normal file
View File

@ -0,0 +1,11 @@
! { dg-do compile }
function reverse(string)
implicit none
character(len=*), intent(in) :: string
character(len=:),allocatable :: reverse
integer i
reverse = string
forall (i=1:len(reverse)) reverse(i:i) = &
reverse(len(reverse)-i+1:len(reverse)-i+1)
end function reverse

63
gcc/testsuite/gfortran.dg/pr55086_1.f90 Normal file
View File

@ -0,0 +1,63 @@
! { dg-do run }
!
implicit none
character(len=5), pointer :: a(:), b(:)
character(len=5), pointer :: c, d
allocate (a(2), b(2), c, d)
a = [ "abcde", "ABCDE" ]
call aloct_pointer_copy_4 (b, a)
!print *, b(1)
!print *, b(2)
if (any (a /= b)) stop 'WRONG'
call aloct_copy_4 (b, a)
!print *, b(1)
!print *, b(2)
if (any (a /= b)) stop 'WRONG'
d = '12345'
c = "abcde"
call test2 (d, c)
!print *, d
if (d /= '1cb15') stop 'WRONG'
call test2p (d, c)
!print *, d
if (d /= '1cb15') stop 'WRONG'
contains
subroutine aloct_pointer_copy_4(o, i)
character(len=*), pointer :: o(:), i(:)
integer :: nl1, nu1
integer :: i1
nl1 = lbound(i,dim=1)
nu1 = ubound(i,dim=1)
forall (i1 = nl1:nu1) o(i1) = i(i1)
end subroutine aloct_pointer_copy_4
subroutine aloct_copy_4(o, i)
character(len=*), pointer :: o(:), i(:)
integer :: nl1, nu1
integer :: i1
nl1 = lbound(i,dim=1)
nu1 = ubound(i,dim=1)
forall (i1 = nl1:nu1) o(i1) = i(i1)
end subroutine aloct_copy_4
subroutine test2(o, i)
character(len=*) :: o, i
integer :: nl1, nu1
integer :: i1
nl1 = 2
nu1 = 4
forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)
forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
end subroutine test2
subroutine test2p(o, i)
character(len=*), pointer :: o, i
integer :: nl1, nu1
integer :: i1
nl1 = 2
nu1 = 4
forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1) ! <<<< ICE
forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
end subroutine test2p
end

64
gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90 Normal file
View File

@ -0,0 +1,64 @@
! { dg-do run }
! { dg-options "-ftest-forall-temp" }
!
implicit none
character(len=5), pointer :: a(:), b(:)
character(len=5), pointer :: c, d
allocate (a(2), b(2), c, d)
a = [ "abcde", "ABCDE" ]
call aloct_pointer_copy_4 (b, a)
!print *, b(1)
!print *, b(2)
if (any (a /= b)) stop 'WRONG'
call aloct_copy_4 (b, a)
!print *, b(1)
!print *, b(2)
if (any (a /= b)) stop 'WRONG'
d = '12345'
c = "abcde"
call test2 (d, c)
!print *, d
if (d /= '1cb15') stop 'WRONG'
call test2p (d, c)
!print *, d
if (d /= '1cb15') stop 'WRONG'
contains
subroutine aloct_pointer_copy_4(o, i)
character(len=*), pointer :: o(:), i(:)
integer :: nl1, nu1
integer :: i1
nl1 = lbound(i,dim=1)
nu1 = ubound(i,dim=1)
forall (i1 = nl1:nu1) o(i1) = i(i1)
end subroutine aloct_pointer_copy_4
subroutine aloct_copy_4(o, i)
character(len=*), pointer :: o(:), i(:)
integer :: nl1, nu1
integer :: i1
nl1 = lbound(i,dim=1)
nu1 = ubound(i,dim=1)
forall (i1 = nl1:nu1) o(i1) = i(i1)
end subroutine aloct_copy_4
subroutine test2(o, i)
character(len=*) :: o, i
integer :: nl1, nu1
integer :: i1
nl1 = 2
nu1 = 4
forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)
forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
end subroutine test2
subroutine test2p(o, i)
character(len=*), pointer :: o, i
integer :: nl1, nu1
integer :: i1
nl1 = 2
nu1 = 4
forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1) ! <<<< ICE
forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
end subroutine test2p
end

32
gcc/testsuite/gfortran.dg/pr55086_2.f90 Normal file
View File

@ -0,0 +1,32 @@
! { dg-do run }
!
implicit none
character(len=7), pointer :: u
character(len=7), pointer :: v
character(len=7), target :: a
character(len=7), target :: b
integer :: j
b = "1234567"
a = "abcdefg"
u => a
v => b
forall (j = 1:2) a(j:j) = b(j:j)
if (a /= "12cdefg") call abort
forall (j = 2:3) a(j:j) = v(j:j)
if (a /= "123defg") call abort
forall (j = 3:4) u(j:j) = b(j:j)
if (a /= "1234efg") call abort
forall (j = 4:5) u(j:j) = v(j:j)
if (a /= "12345fg") call abort
end

33
gcc/testsuite/gfortran.dg/pr55086_2_tfat.f90 Normal file
View File

@ -0,0 +1,33 @@
! { dg-do run }
! { dg-options "-ftest-forall-temp" }
!
implicit none
character(len=7), pointer :: u
character(len=7), pointer :: v
character(len=7), target :: a
character(len=7), target :: b
integer :: j
b = "1234567"
a = "abcdefg"
u => a
v => b
forall (j = 1:2) a(j:j) = b(j:j)
if (a /= "12cdefg") call abort
forall (j = 2:3) a(j:j) = v(j:j)
if (a /= "123defg") call abort
forall (j = 3:4) u(j:j) = b(j:j)
if (a /= "1234efg") call abort
forall (j = 4:5) u(j:j) = v(j:j)
if (a /= "12345fg") call abort
end

40
gcc/testsuite/gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90 Normal file
View File

@ -0,0 +1,40 @@
! { dg-do run }
! { dg-options "-ftest-forall-temp" }
! This is a copy of aliasing_dummy_4.f90, with an option set to improve
! test coverage by forcing forall code to use a temporary.
!
program test_f90
integer, parameter :: N = 2
type test_type
integer a(N, N)
end type
type (test_type) s(N, N)
forall (l = 1:N, m = 1:N) &
s(l, m)%a(:, :) = reshape ([((i*l + 10*j*m +100, i = 1, N), j = 1, N)], [N, N])
call test_sub(s%a(1, 1), 1000) ! Test the original problem.
if ( any (s(1, 1)%a(:, :) /= reshape ([1111, 112, 121, 122], [2, 2]))) call abort ()
if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort ()
if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort ()
if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort ()
call test_sub(s(1, 1)%a(:, :), 1000) ! Check "normal" references.
if ( any (s(1, 1)%a(:, :) /= reshape ([2111,1112,1121,1122], [2, 2]))) call abort ()
if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort ()
if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort ()
if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort ()
contains
subroutine test_sub(array, offset)
integer array(:, :), offset
forall (i = 1:N, j = 1:N) &
array(i, j) = array(i, j) + offset
end subroutine
end program