mirrors/gcc
1
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-11-23 02:44:18 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

fortran: Inline non-character MINLOC/MAXLOC with DIM [PR90608]

Browse Source 
Enable generation of inline MINLOC/MAXLOC code in the cases where DIM is a
constant, and either ARRAY is of REAL type or MASK is an array.  Those cases
are the remaining bits to fully support inlining of non-CHARACTER
MINLOC/MAXLOC with constant DIM.  They are treated together because they
generate similar code, the NANs for REAL types being handled a bit like a
second level of masking.  These are the cases for which we generate two
loops.

This change affects the code generating the second loop, that was
previously accessible only in cases ARRAY had rank 1.

The main changes are in gfc_conv_intrinsic_minmaxloc the replacement of the
locally initialized scalarization loop with the one provided and previously
initialized by the scalarizer.  Same goes for the locally initialized MASK
scalarizer chain.

As this is enabling the code generating a second loop in a context of
reduction and nested loops, care is taken not to advance the parent
scalarization chain twice.

The scalarization chain element(s) for an array MASK are inserted in the
chain at a different place from that of a scalar MASK.  This is done on
purpose to match the code consuming the chains which are in different places
for scalar and array MASK.

	PR fortran/90608

gcc/fortran/ChangeLog:

	* trans-intrinsic.cc (gfc_inline_intrinsic_function_p): Return TRUE
	for MINLOC/MAXLOC with constant DIM and either REAL ARRAY or
	non-scalar MASK.
	(walk_inline_intrinsic_minmaxloc): Walk MASK and if it's an array
	add the chain obtained before that of ARRAY.
	(gfc_conv_intrinsic_minmaxloc): Use the nested loop if there is one.
	To evaluate MASK (respectively ARRAY in the second loop), inherit
	the scalarizer chain if in a nested loop, otherwise keep using the
	chain obtained by walking MASK (respectively ARRAY).  If there is a
	nested loop, avoid advancing the parent scalarization chain a second
	time in the second loop.

gcc/testsuite/ChangeLog:

	* gfortran.dg/minmaxloc_21.f90: New test.
This commit is contained in:
Mikael Morin 2024-08-08 12:23:16 +02:00
parent 933b146f0a
commit f5a87c8d8c
2 changed files with 625 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
gcc/fortran/trans-intrinsic.cc
View File

@ -5478,6 +5478,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
gfc_actual_arglist *back_arg;
gfc_ss *arrayss = nullptr;
gfc_ss *maskss = nullptr;
gfc_ss *orig_ss = nullptr;
gfc_se arrayse;
gfc_se maskse;
gfc_se nested_se;
@ -5712,6 +5713,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
if (nested_loop)
{
ploop = enter_nested_loop (&nested_se);
orig_ss = nested_se.ss;
ploop->temp_dim = 1;
}
else
@ -5786,9 +5788,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
}
else
{
gcc_assert (!nested_loop);
for (int i = 0; i < loop.dimen; i++)
gfc_add_modify (&loop.pre, pos[i], gfc_index_zero_node);
for (int i = 0; i < ploop->dimen; i++)
gfc_add_modify (&ploop->pre, pos[i], gfc_index_zero_node);
lab1 = gfc_build_label_decl (NULL_TREE);
TREE_USED (lab1) = 1;
lab2 = gfc_build_label_decl (NULL_TREE);
@ -5819,10 +5820,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
/* If we have a mask, only check this element if the mask is set. */
if (maskexpr && maskexpr->rank > 0)
{
gcc_assert (!nested_loop);
gfc_init_se (&maskse, NULL);
gfc_copy_loopinfo_to_se (&maskse, &loop);
maskse.ss = maskss;
gfc_init_se (&maskse, base_se);
gfc_copy_loopinfo_to_se (&maskse, ploop);
if (!nested_loop)
maskse.ss = maskss;
gfc_conv_expr_val (&maskse, maskexpr);
gfc_add_block_to_block (&body, &maskse.pre);
@ -5850,13 +5851,11 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
stmtblock_t ifblock2;
tree ifbody2;
gcc_assert (!nested_loop);
gfc_start_block (&ifblock2);
for (int i = 0; i < loop.dimen; i++)
for (int i = 0; i < ploop->dimen; i++)
{
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
loop.loopvar[i], offset[i]);
ploop->loopvar[i], offset[i]);
gfc_add_modify (&ifblock2, pos[i], tmp);
}
ifbody2 = gfc_finish_block (&ifblock2);
@ -5940,17 +5939,24 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
if (lab1)
{
gcc_assert (!nested_loop);
for (int i = 0; i < ploop->dimen; i++)
ploop->from[i] = fold_build3_loc (input_location, COND_EXPR,
TREE_TYPE (ploop->from[i]),
second_loop_entry, idx[i],
ploop->from[i]);
for (int i = 0; i < loop.dimen; i++)
loop.from[i] = fold_build3_loc (input_location, COND_EXPR,
TREE_TYPE (loop.from[i]),
second_loop_entry, idx[i],
loop.from[i]);
gfc_trans_scalarized_loop_boundary (ploop, &body);
gfc_trans_scalarized_loop_boundary (&loop, &body);
if (nested_loop)
{
/* The first loop already advanced the parent se'ss chain, so clear
the parent now to avoid doing it a second time, making the chain
out of sync. */
nested_se.parent = nullptr;
nested_se.ss = orig_ss;
}
stmtblock_t * const outer_block = &loop.code[loop.dimen - 1];
stmtblock_t * const outer_block = &ploop->code[ploop->dimen - 1];
if (HONOR_NANS (DECL_MODE (limit)))
{
@ -5959,7 +5965,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
stmtblock_t init_block;
gfc_init_block (&init_block);
for (int i = 0; i < loop.dimen; i++)
for (int i = 0; i < ploop->dimen; i++)
gfc_add_modify (&init_block, pos[i], gfc_index_one_node);
tree ifbody = gfc_finish_block (&init_block);
@ -5975,9 +5981,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
/* If we have a mask, only check this element if the mask is set. */
if (maskexpr && maskexpr->rank > 0)
{
gfc_init_se (&maskse, NULL);
gfc_copy_loopinfo_to_se (&maskse, &loop);
maskse.ss = maskss;
gfc_init_se (&maskse, base_se);
gfc_copy_loopinfo_to_se (&maskse, ploop);
if (!nested_loop)
maskse.ss = maskss;
gfc_conv_expr_val (&maskse, maskexpr);
gfc_add_block_to_block (&body, &maskse.pre);
@ -5987,9 +5994,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
gfc_init_block (&block);
/* Compare with the current limit. */
gfc_init_se (&arrayse, NULL);
gfc_copy_loopinfo_to_se (&arrayse, &loop);
arrayse.ss = arrayss;
gfc_init_se (&arrayse, base_se);
gfc_copy_loopinfo_to_se (&arrayse, ploop);
if (!nested_loop)
arrayse.ss = arrayss;
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
@ -5999,10 +6007,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
/* Assign the value to the limit... */
gfc_add_modify (&ifblock, limit, arrayse.expr);
for (int i = 0; i < loop.dimen; i++)
for (int i = 0; i < ploop->dimen; i++)
{
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
loop.loopvar[i], offset[i]);
ploop->loopvar[i], offset[i]);
gfc_add_modify (&ifblock, pos[i], tmp);
}
@ -6061,7 +6069,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
gfc_trans_scalarizing_loops (ploop, &body);
if (lab2)
gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
gfc_add_expr_to_block (&ploop->pre, build1_v (LABEL_EXPR, lab2));
/* For a scalar mask, enclose the loop in an if statement. */
if (maskexpr && maskexpr->rank == 0)
@ -11871,6 +11879,18 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
gfc_ss *tmp_ss = gfc_ss_terminator;
bool scalar_mask = false;
if (mask)
{
gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask);
if (mask_ss == tmp_ss)
scalar_mask = true;
else if (maybe_absent_optional_variable (mask))
mask_ss->info->can_be_null_ref = true;
tmp_ss = mask_ss;
}
gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
gcc_assert (array_ss != tmp_ss);
@ -11882,7 +11902,7 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED)
gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
tail->next = ss;
if (mask)
if (scalar_mask)
{
tmp_ss = gfc_get_scalar_ss (tmp_ss, mask);
/* MASK can be a forwarded optional argument, so make the necessary setup
@ -12032,11 +12052,9 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr)
gfc_actual_arglist *array_arg = expr->value.function.actual;
gfc_actual_arglist *dim_arg = array_arg->next;
gfc_actual_arglist *mask_arg = dim_arg->next;
gfc_expr *array = array_arg->expr;
gfc_expr *dim = dim_arg->expr;
gfc_expr *mask = mask_arg->expr;
if (!(array->ts.type == BT_INTEGER
|| array->ts.type == BT_REAL))
@ -12045,19 +12063,11 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr)
if (array->rank == 1)
return true;
if (dim == nullptr)
return true;
if (dim->expr_type != EXPR_CONSTANT)
if (dim != nullptr
&& dim->expr_type != EXPR_CONSTANT)
return false;
if (array->ts.type != BT_INTEGER)
return false;
if (mask == nullptr || mask->rank == 0)
return true;
return false;
return true;
}
default:

572
gcc/testsuite/gfortran.dg/minmaxloc_21.f90 Normal file
View File

@ -0,0 +1,572 @@
! { dg-do compile }
! { dg-additional-options "-O -fdump-tree-original" }
! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?minloc" "original" } }
! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?maxloc" "original" } }
!
! PR fortran/90608
! Check that all MINLOC and MAXLOC calls are inlined with optimizations,
! when DIM is a constant, and either ARRAY has REAL type or MASK is non-scalar.
subroutine check_real_maxloc
implicit none
integer, parameter :: data60(*) = (/ 2, 5, 4, 6, 0, 9, 3, 5, 4, 4, &
1, 7, 3, 2, 1, 2, 5, 4, 6, 0, &
9, 3, 5, 4, 4, 1, 7, 3, 2, 1, &
2, 5, 4, 6, 0, 9, 3, 5, 4, 4, &
1, 7, 3, 2, 1, 2, 5, 4, 6, 0, &
9, 3, 5, 4, 4, 1, 7, 3, 2, 1 /)
integer, parameter :: data1(*) = (/ 2, 3, 2, 3, &
1, 2, 3, 2, &
3, 1, 2, 3, &
2, 3, 1, 2, &
3, 2, 3, 1 /)
integer, parameter :: data2(*) = (/ 2, 1, 2, &
3, 2, 3, &
4, 3, 4, &
2, 1, 2, &
1, 2, 1 /)
integer, parameter :: data3(*) = (/ 5, 1, 5, &
1, 2, 1, &
2, 1, 2, &
3, 2, 3 /)
call check_real_const_shape_rank_3
call check_real_const_shape_empty_4
call check_real_alloc_rank_3
call check_real_alloc_empty_4
contains
subroutine check_real_const_shape_rank_3()
real :: a(3,4,5)
integer, allocatable :: r(:,:)
a = reshape((/ real:: data60 /), shape(a))
r = maxloc(a, dim=1)
if (any(shape(r) /= (/ 4, 5 /))) error stop 1
if (any(r /= reshape((/ real:: data1 /), (/ 4, 5 /)))) error stop 2
r = maxloc(a, dim=2)
if (any(shape(r) /= (/ 3, 5 /))) error stop 3
if (any(r /= reshape((/ real:: data2 /), (/ 3, 5 /)))) error stop 4
r = maxloc(a, dim=3)
if (any(shape(r) /= (/ 3, 4 /))) error stop 5
if (any(r /= reshape((/ real:: data3 /), (/ 3, 4 /)))) error stop 6
end subroutine
subroutine check_real_const_shape_empty_4()
real :: a(9,3,0,7)
integer, allocatable :: r(:,:,:)
a = reshape((/ real:: /), shape(a))
r = maxloc(a, dim=1)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 11
r = maxloc(a, dim=2)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 12
r = maxloc(a, dim=3)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 13
if (any(r /= 0)) error stop 14
r = maxloc(a, dim=4)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 15
end subroutine
subroutine check_real_alloc_rank_3()
real, allocatable :: a(:,:,:)
integer, allocatable :: r(:,:)
allocate(a(3,4,5))
a(:,:,:) = reshape((/ real:: data60 /), shape(a))
r = maxloc(a, dim=1)
if (any(shape(r) /= (/ 4, 5 /))) error stop 21
if (any(r /= reshape((/ real:: data1 /), shape=(/ 4, 5 /)))) error stop 22
r = maxloc(a, dim=2)
if (any(shape(r) /= (/ 3, 5 /))) error stop 23
if (any(r /= reshape((/ real:: data2 /), shape=(/ 3, 5 /)))) error stop 24
r = maxloc(a, dim=3)
if (any(shape(r) /= (/ 3, 4 /))) error stop 25
if (any(r /= reshape((/ real:: data3 /), shape=(/ 3, 4 /)))) error stop 26
end subroutine
subroutine check_real_alloc_empty_4()
real, allocatable :: a(:,:,:,:)
integer, allocatable :: r(:,:,:)
allocate(a(9,3,0,7))
a(:,:,:,:) = reshape((/ real:: /), shape(a))
r = maxloc(a, dim=1)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 31
r = maxloc(a, dim=2)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 32
r = maxloc(a, dim=3)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 33
if (any(r /= 0)) error stop 34
r = maxloc(a, dim=4)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 35
end subroutine
end subroutine
subroutine check_maxloc_with_mask
implicit none
integer, parameter :: data60(*) = (/ 2, 5, 4, 6, 0, 9, 3, 5, 4, 4, &
1, 7, 3, 2, 1, 2, 5, 4, 6, 0, &
9, 3, 5, 4, 4, 1, 7, 3, 2, 1, &
2, 5, 4, 6, 0, 9, 3, 5, 4, 4, &
1, 7, 3, 2, 1, 2, 5, 4, 6, 0, &
9, 3, 5, 4, 4, 1, 7, 3, 2, 1 /)
logical, parameter :: mask60(*) = (/ .true. , .false., .false., .false., &
.true. , .false., .true. , .false., &
.false., .true. , .true. , .false., &
.true. , .true. , .true. , .true. , &
.false., .true. , .false., .true. , &
.false., .true. , .false., .true. , &
.true. , .false., .false., .true. , &
.true. , .true. , .true. , .false., &
.false., .false., .true. , .false., &
.true. , .false., .true. , .true. , &
.true. , .false., .true. , .true. , &
.false., .true. , .false., .true. , &
.false., .true. , .false., .false., &
.false., .true. , .true. , .true. , &
.false., .true. , .false., .true. /)
integer, parameter :: data1(*) = (/ 2, 3, 2, 3, &
1, 2, 3, 2, &
3, 1, 2, 3, &
2, 3, 1, 2, &
3, 2, 3, 1 /)
integer, parameter :: data2(*) = (/ 2, 1, 2, &
3, 2, 3, &
4, 3, 4, &
2, 1, 2, &
1, 2, 1 /)
integer, parameter :: data3(*) = (/ 5, 1, 5, &
1, 2, 1, &
2, 1, 2, &
3, 2, 3 /)
integer, parameter :: data1m(*) = (/ 1, 2, 1, 1, &
1, 3, 2, 3, &
1, 1, 1, 2, &
3, 1, 1, 3, &
2, 3, 1, 1 /)
integer, parameter :: data2m(*) = (/ 4, 4, 0, &
1, 1, 2, &
1, 2, 2, &
2, 3, 1, &
3, 3, 2 /)
integer, parameter :: data3m(*) = (/ 3, 2, 4, &
4, 3, 2, &
5, 4, 0, &
1, 1, 2 /)
call check_int_const_shape_rank_3
call check_int_const_shape_empty_4
call check_int_alloc_rank_3
call check_int_alloc_empty_4
call check_real_const_shape_rank_3
call check_real_const_shape_empty_4
call check_real_alloc_rank_3
call check_real_alloc_empty_4
contains
subroutine check_int_const_shape_rank_3()
integer :: a(3,4,5)
logical :: m(3,4,5)
integer, allocatable :: r(:,:)
a = reshape(data60, shape(a))
m = reshape(mask60, shape(m))
r = maxloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 4, 5 /))) error stop 41
if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 42
r = maxloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 3, 5 /))) error stop 43
if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 44
r = maxloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 3, 4 /))) error stop 45
if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 46
end subroutine
subroutine check_int_const_shape_empty_4()
integer :: a(9,3,0,7)
logical :: m(9,3,0,7)
integer, allocatable :: r(:,:,:)
a = reshape((/ integer:: /), shape(a))
m = reshape((/ logical:: /), shape(m))
r = maxloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 51
r = maxloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 52
r = maxloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 53
if (any(r /= 0)) error stop 54
r = maxloc(a, dim = 4, mask = m)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 55
end subroutine
subroutine check_int_alloc_rank_3()
integer, allocatable :: a(:,:,:)
logical, allocatable :: m(:,:,:)
integer, allocatable :: r(:,:)
allocate(a(3,4,5), m(3,4,5))
a(:,:,:) = reshape(data60, shape(a))
m(:,:,:) = reshape(mask60, shape(m))
r = maxloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 4, 5 /))) error stop 61
if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 62
r = maxloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 3, 5 /))) error stop 63
if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 64
r = maxloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 3, 4 /))) error stop 65
if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 66
end subroutine
subroutine check_int_alloc_empty_4()
integer, allocatable :: a(:,:,:,:)
logical, allocatable :: m(:,:,:,:)
integer, allocatable :: r(:,:,:)
allocate(a(9,3,0,7), m(9,3,0,7))
a(:,:,:,:) = reshape((/ integer:: /), shape(a))
m(:,:,:,:) = reshape((/ logical:: /), shape(m))
r = maxloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 71
r = maxloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 72
r = maxloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 73
if (any(r /= 0)) error stop 74
r = maxloc(a, dim = 4, mask = m)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 75
end subroutine
subroutine check_real_const_shape_rank_3()
real :: a(3,4,5)
logical :: m(3,4,5)
integer, allocatable :: r(:,:)
a = reshape((/ real:: data60 /), shape(a))
m = reshape(mask60, shape(m))
r = maxloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 4, 5 /))) error stop 81
if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 82
r = maxloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 3, 5 /))) error stop 83
if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 84
r = maxloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 3, 4 /))) error stop 85
if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 86
end subroutine
subroutine check_real_const_shape_empty_4()
real :: a(9,3,0,7)
logical :: m(9,3,0,7)
integer, allocatable :: r(:,:,:)
a = reshape((/ real:: /), shape(a))
m = reshape((/ logical:: /), shape(m))
r = maxloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 91
r = maxloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 92
r = maxloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 93
if (any(r /= 0)) error stop 94
r = maxloc(a, dim = 4, mask = m)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 95
end subroutine
subroutine check_real_alloc_rank_3()
real, allocatable :: a(:,:,:)
logical, allocatable :: m(:,:,:)
integer, allocatable :: r(:,:)
allocate(a(3,4,5), m(3,4,5))
a(:,:,:) = reshape((/ real:: data60 /), shape(a))
m(:,:,:) = reshape(mask60, shape(m))
r = maxloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 4, 5 /))) error stop 101
if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 102
r = maxloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 3, 5 /))) error stop 103
if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 104
r = maxloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 3, 4 /))) error stop 105
if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 106
end subroutine
subroutine check_real_alloc_empty_4()
real, allocatable :: a(:,:,:,:)
logical, allocatable :: m(:,:,:,:)
integer, allocatable :: r(:,:,:)
allocate(a(9,3,0,7), m(9,3,0,7))
a(:,:,:,:) = reshape((/ real:: /), shape(a))
m(:,:,:,:) = reshape((/ logical :: /), shape(m))
r = maxloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 111
r = maxloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 112
r = maxloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 113
if (any(r /= 0)) error stop 114
r = maxloc(a, dim = 4, mask = m)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 115
end subroutine
end subroutine
subroutine check_real_minloc
implicit none
integer, parameter :: data60(*) = (/ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, &
8, 2, 6, 7, 8, 7, 4, 5, 3, 9, &
0, 6, 4, 5, 5, 8, 2, 6, 7, 8, &
7, 4, 5, 3, 9, 0, 6, 4, 5, 5, &
8, 2, 6, 7, 8, 7, 4, 5, 3, 9, &
0, 6, 4, 5, 5, 8, 2, 6, 7, 8 /)
integer, parameter :: data1(*) = (/ 2, 3, 2, 3, &
1, 2, 3, 2, &
3, 1, 2, 3, &
2, 3, 1, 2, &
3, 2, 3, 1 /)
integer, parameter :: data2(*) = (/ 2, 1, 2, &
3, 2, 3, &
4, 3, 4, &
2, 1, 2, &
1, 2, 1 /)
integer, parameter :: data3(*) = (/ 5, 1, 5, &
1, 2, 1, &
2, 1, 2, &
3, 2, 3 /)
call check_real_const_shape_rank_3
call check_real_const_shape_empty_4
call check_real_alloc_rank_3
call check_real_alloc_empty_4
contains
subroutine check_real_const_shape_rank_3()
real :: a(3,4,5)
integer, allocatable :: r(:,:)
a = reshape((/ real:: data60 /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 4, 5 /))) error stop 141
if (any(r /= reshape((/ real:: data1 /), (/ 4, 5 /)))) error stop 142
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 3, 5 /))) error stop 143
if (any(r /= reshape((/ real:: data2 /), (/ 3, 5 /)))) error stop 144
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 3, 4 /))) error stop 145
if (any(r /= reshape((/ real:: data3 /), (/ 3, 4 /)))) error stop 146
end subroutine
subroutine check_real_const_shape_empty_4()
real :: a(9,3,0,7)
integer, allocatable :: r(:,:,:)
a = reshape((/ real:: /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 151
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 152
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 153
if (any(r /= 0)) error stop 154
r = minloc(a, dim=4)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 155
end subroutine
subroutine check_real_alloc_rank_3()
real, allocatable :: a(:,:,:)
integer, allocatable :: r(:,:)
allocate(a(3,4,5))
a(:,:,:) = reshape((/ real:: data60 /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 4, 5 /))) error stop 161
if (any(r /= reshape((/ real:: data1 /), shape=(/ 4, 5 /)))) error stop 162
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 3, 5 /))) error stop 163
if (any(r /= reshape((/ real:: data2 /), shape=(/ 3, 5 /)))) error stop 164
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 3, 4 /))) error stop 165
if (any(r /= reshape((/ real:: data3 /), shape=(/ 3, 4 /)))) error stop 166
end subroutine
subroutine check_real_alloc_empty_4()
real, allocatable :: a(:,:,:,:)
integer, allocatable :: r(:,:,:)
allocate(a(9,3,0,7))
a(:,:,:,:) = reshape((/ real:: /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 171
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 172
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 173
if (any(r /= 0)) error stop 174
r = minloc(a, dim=4)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 175
end subroutine
end subroutine
subroutine check_minloc_with_mask
implicit none
integer, parameter :: data60(*) = (/ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, &
8, 2, 6, 7, 8, 7, 4, 5, 3, 9, &
0, 6, 4, 5, 5, 8, 2, 6, 7, 8, &
7, 4, 5, 3, 9, 0, 6, 4, 5, 5, &
8, 2, 6, 7, 8, 7, 4, 5, 3, 9, &
0, 6, 4, 5, 5, 8, 2, 6, 7, 8 /)
logical, parameter :: mask60(*) = (/ .true. , .false., .false., .false., &
.true. , .false., .true. , .false., &
.false., .true. , .true. , .false., &
.true. , .true. , .true. , .true. , &
.false., .true. , .false., .true. , &
.false., .true. , .false., .true. , &
.true. , .false., .false., .true. , &
.true. , .true. , .true. , .false., &
.false., .false., .true. , .false., &
.true. , .false., .true. , .true. , &
.true. , .false., .true. , .true. , &
.false., .true. , .false., .true. , &
.false., .true. , .false., .false., &
.false., .true. , .true. , .true. , &
.false., .true. , .false., .true. /)
integer, parameter :: data1(*) = (/ 2, 3, 2, 3, &
1, 2, 3, 2, &
3, 1, 2, 3, &
2, 3, 1, 2, &
3, 2, 3, 1 /)
integer, parameter :: data2(*) = (/ 2, 1, 2, &
3, 2, 3, &
4, 3, 4, &
2, 1, 2, &
1, 2, 1 /)
integer, parameter :: data3(*) = (/ 5, 1, 5, &
1, 2, 1, &
2, 1, 2, &
3, 2, 3 /)
integer, parameter :: data1m(*) = (/ 1, 2, 1, 1, &
1, 3, 2, 3, &
1, 1, 1, 2, &
3, 1, 1, 3, &
2, 3, 1, 1 /)
integer, parameter :: data2m(*) = (/ 4, 4, 0, &
1, 1, 2, &
1, 2, 2, &
2, 3, 1, &
3, 3, 2 /)
integer, parameter :: data3m(*) = (/ 3, 2, 4, &
4, 3, 2, &
5, 4, 0, &
1, 1, 2 /)
call check_int_const_shape_rank_3
call check_int_const_shape_empty_4
call check_int_alloc_rank_3
call check_int_alloc_empty_4
call check_real_const_shape_rank_3
call check_real_const_shape_empty_4
call check_real_alloc_rank_3
call check_real_alloc_empty_4
call check_lower_bounds
call check_dependencies
contains
subroutine check_int_const_shape_rank_3()
integer :: a(3,4,5)
logical :: m(3,4,5)
integer, allocatable :: r(:,:)
a = reshape(data60, shape(a))
m = reshape(mask60, shape(m))
r = minloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 4, 5 /))) error stop 181
if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 182
r = minloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 3, 5 /))) error stop 183
if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 184
r = minloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 3, 4 /))) error stop 185
if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 186
end subroutine
subroutine check_int_const_shape_empty_4()
integer :: a(9,3,0,7)
logical :: m(9,3,0,7)
integer, allocatable :: r(:,:,:)
a = reshape((/ integer:: /), shape(a))
m = reshape((/ logical:: /), shape(m))
r = minloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 191
r = minloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 192
r = minloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 193
if (any(r /= 0)) error stop 194
r = minloc(a, dim = 4, mask = m)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 195
end subroutine
subroutine check_int_alloc_rank_3()
integer, allocatable :: a(:,:,:)
logical, allocatable :: m(:,:,:)
integer, allocatable :: r(:,:)
allocate(a(3,4,5), m(3,4,5))
a(:,:,:) = reshape(data60, shape(a))
m(:,:,:) = reshape(mask60, shape(m))
r = minloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 4, 5 /))) error stop 201
if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 202
r = minloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 3, 5 /))) error stop 203
if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 204
r = minloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 3, 4 /))) error stop 205
if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 206
end subroutine
subroutine check_int_alloc_empty_4()
integer, allocatable :: a(:,:,:,:)
logical, allocatable :: m(:,:,:,:)
integer, allocatable :: r(:,:,:)
allocate(a(9,3,0,7), m(9,3,0,7))
a(:,:,:,:) = reshape((/ integer:: /), shape(a))
m(:,:,:,:) = reshape((/ logical:: /), shape(m))
r = minloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 211
r = minloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 212
r = minloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 213
if (any(r /= 0)) error stop 214
r = minloc(a, dim = 4, mask = m)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 215
end subroutine
subroutine check_real_const_shape_rank_3()
real :: a(3,4,5)
logical :: m(3,4,5)
integer, allocatable :: r(:,:)
a = reshape((/ real:: data60 /), shape(a))
m = reshape(mask60, shape(m))
r = minloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 4, 5 /))) error stop 221
if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 222
r = minloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 3, 5 /))) error stop 223
if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 224
r = minloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 3, 4 /))) error stop 225
if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 226
end subroutine
subroutine check_real_const_shape_empty_4()
real :: a(9,3,0,7)
logical :: m(9,3,0,7)
integer, allocatable :: r(:,:,:)
a = reshape((/ real:: /), shape(a))
m = reshape((/ logical:: /), shape(m))
r = minloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 231
r = minloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 232
r = minloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 233
if (any(r /= 0)) error stop 234
r = minloc(a, dim = 4, mask = m)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 235
end subroutine
subroutine check_real_alloc_rank_3()
real, allocatable :: a(:,:,:)
logical, allocatable :: m(:,:,:)
integer, allocatable :: r(:,:)
allocate(a(3,4,5), m(3,4,5))
a(:,:,:) = reshape((/ real:: data60 /), shape(a))
m(:,:,:) = reshape(mask60, shape(m))
r = minloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 4, 5 /))) error stop 241
if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 242
r = minloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 3, 5 /))) error stop 243
if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 244
r = minloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 3, 4 /))) error stop 245
if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 246
end subroutine
subroutine check_real_alloc_empty_4()
real, allocatable :: a(:,:,:,:)
logical, allocatable :: m(:,:,:,:)
integer, allocatable :: r(:,:,:)
allocate(a(9,3,0,7), m(9,3,0,7))
a(:,:,:,:) = reshape((/ real:: /), shape(a))
m(:,:,:,:) = reshape((/ logical :: /), shape(m))
r = minloc(a, dim = 1, mask = m)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 251
r = minloc(a, dim = 2, mask = m)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 252
r = minloc(a, dim = 3, mask = m)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 253
if (any(r /= 0)) error stop 254
r = minloc(a, dim = 4, mask = m)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 255
end subroutine
end subroutine