https://gcc.gnu.org/g:bd029d3c04a1f54ddbb24032994028480476b308
commit bd029d3c04a1f54ddbb24032994028480476b308
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Thu Aug 8 12:23:16 2024 +0200
fortran: Inline non-character MINLOC/MAXLOC with DIM [PR90608]
Enable generation of inline MINLOC/MAXLOC code in the cases where DIM is a
constant, and either ARRAY is of floating point or MASK is an array. Those
cases are the remaining bits to fully support inlining of non-CHARACTER
MINLOC/MAXLOC with 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 parent
scalarization chains 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 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.
Diff:
---
gcc/fortran/trans-intrinsic.cc | 96 ++---
gcc/testsuite/gfortran.dg/minmaxloc_21.f90 | 572 +++++++++++++++++++++++++++++
2 files changed, 625 insertions(+), 43 deletions(-)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 60e97ed4528f..47964e63959f 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -5477,6 +5477,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;
@@ -5711,6 +5712,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
@@ -5785,9 +5787,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);
@@ -5818,10 +5819,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);
@@ -5849,13 +5850,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);
@@ -5939,17 +5938,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)))
{
@@ -5958,7 +5964,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);
@@ -5974,9 +5980,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);
@@ -5986,9 +5993,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);
@@ -5998,10 +6006,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);
}
@@ -6060,7 +6068,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)
@@ -11870,6 +11878,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);
@@ -11881,7 +11901,7 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr
*expr ATTRIBUTE_UNUSED)
gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val);
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
@@ -12031,11 +12051,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))
@@ -12044,19 +12062,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:
diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_21.f90
b/gcc/testsuite/gfortran.dg/minmaxloc_21.f90
new file mode 100644
index 000000000000..d3412b0a3218
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/minmaxloc_21.f90
@@ -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 /))) stop 51
+ if (any(r /= reshape((/ real:: data1 /), (/ 4, 5 /)))) stop 52
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 53
+ if (any(r /= reshape((/ real:: data2 /), (/ 3, 5 /)))) stop 54
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 55
+ if (any(r /= reshape((/ real:: data3 /), (/ 3, 4 /)))) stop 56
+ 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 /))) stop 61
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 62
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 63
+ if (any(r /= 0)) stop 64
+ r = maxloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 65
+ 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 /))) stop 71
+ if (any(r /= reshape((/ real:: data1 /), shape=(/ 4, 5 /)))) stop 72
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 73
+ if (any(r /= reshape((/ real:: data2 /), shape=(/ 3, 5 /)))) stop 74
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 75
+ if (any(r /= reshape((/ real:: data3 /), shape=(/ 3, 4 /)))) stop 76
+ 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 /))) stop 81
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 82
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 83
+ if (any(r /= 0)) stop 84
+ r = maxloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 85
+ 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 /))) stop 11
+ if (any(r /= reshape(data1m, (/ 4, 5 /)))) stop 12
+ r = maxloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 13
+ if (any(r /= reshape(data2m, (/ 3, 5 /)))) stop 14
+ r = maxloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 15
+ if (any(r /= reshape(data3m, (/ 3, 4 /)))) stop 16
+ 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 /))) stop 61
+ r = maxloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 62
+ r = maxloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 63
+ if (any(r /= 0)) stop 64
+ r = maxloc(a, dim = 4, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 65
+ 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 /))) stop 71
+ if (any(r /= reshape(data1m, (/ 4, 5 /)))) stop 72
+ r = maxloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 73
+ if (any(r /= reshape(data2m, (/ 3, 5 /)))) stop 74
+ r = maxloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 75
+ if (any(r /= reshape(data3m, (/ 3, 4 /)))) stop 76
+ 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 /))) stop 101
+ r = maxloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 102
+ r = maxloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 103
+ if (any(r /= 0)) stop 104
+ r = maxloc(a, dim = 4, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 105
+ 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 /))) stop 111
+ if (any(r /= reshape(data1m, (/ 4, 5 /)))) stop 112
+ r = maxloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 113
+ if (any(r /= reshape(data2m, (/ 3, 5 /)))) stop 114
+ r = maxloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 115
+ if (any(r /= reshape(data3m, (/ 3, 4 /)))) stop 116
+ 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 /))) stop 161
+ r = maxloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 162
+ r = maxloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 163
+ if (any(r /= 0)) stop 164
+ r = maxloc(a, dim = 4, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 165
+ 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 /))) stop 171
+ if (any(r /= reshape(data1m, (/ 4, 5 /)))) stop 172
+ r = maxloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 173
+ if (any(r /= reshape(data2m, (/ 3, 5 /)))) stop 174
+ r = maxloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 175
+ if (any(r /= reshape(data3m, (/ 3, 4 /)))) stop 176
+ 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 /))) stop 201
+ r = maxloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 202
+ r = maxloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 203
+ if (any(r /= 0)) stop 204
+ r = maxloc(a, dim = 4, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 205
+ 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 /))) stop 51
+ if (any(r /= reshape((/ real:: data1 /), (/ 4, 5 /)))) stop 52
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 53
+ if (any(r /= reshape((/ real:: data2 /), (/ 3, 5 /)))) stop 54
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 55
+ if (any(r /= reshape((/ real:: data3 /), (/ 3, 4 /)))) stop 56
+ 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 /))) stop 61
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 62
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 63
+ if (any(r /= 0)) stop 64
+ r = minloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 65
+ 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 /))) stop 71
+ if (any(r /= reshape((/ real:: data1 /), shape=(/ 4, 5 /)))) stop 72
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 73
+ if (any(r /= reshape((/ real:: data2 /), shape=(/ 3, 5 /)))) stop 74
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 75
+ if (any(r /= reshape((/ real:: data3 /), shape=(/ 3, 4 /)))) stop 76
+ 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 /))) stop 81
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 82
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 83
+ if (any(r /= 0)) stop 84
+ r = minloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 85
+ 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 /))) stop 11
+ if (any(r /= reshape(data1m, (/ 4, 5 /)))) stop 12
+ r = minloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 13
+ if (any(r /= reshape(data2m, (/ 3, 5 /)))) stop 14
+ r = minloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 15
+ if (any(r /= reshape(data3m, (/ 3, 4 /)))) stop 16
+ 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 /))) stop 61
+ r = minloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 62
+ r = minloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 63
+ if (any(r /= 0)) stop 64
+ r = minloc(a, dim = 4, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 65
+ 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 /))) stop 71
+ if (any(r /= reshape(data1m, (/ 4, 5 /)))) stop 72
+ r = minloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 73
+ if (any(r /= reshape(data2m, (/ 3, 5 /)))) stop 74
+ r = minloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 75
+ if (any(r /= reshape(data3m, (/ 3, 4 /)))) stop 76
+ 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 /))) stop 101
+ r = minloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 102
+ r = minloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 103
+ if (any(r /= 0)) stop 104
+ r = minloc(a, dim = 4, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 105
+ 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 /))) stop 111
+ if (any(r /= reshape(data1m, (/ 4, 5 /)))) stop 112
+ r = minloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 113
+ if (any(r /= reshape(data2m, (/ 3, 5 /)))) stop 114
+ r = minloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 115
+ if (any(r /= reshape(data3m, (/ 3, 4 /)))) stop 116
+ 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 /))) stop 161
+ r = minloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 162
+ r = minloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 163
+ if (any(r /= 0)) stop 164
+ r = minloc(a, dim = 4, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 165
+ 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 /))) stop 171
+ if (any(r /= reshape(data1m, (/ 4, 5 /)))) stop 172
+ r = minloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 173
+ if (any(r /= reshape(data2m, (/ 3, 5 /)))) stop 174
+ r = minloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 175
+ if (any(r /= reshape(data3m, (/ 3, 4 /)))) stop 176
+ 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 /))) stop 201
+ r = minloc(a, dim = 2, mask = m)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 202
+ r = minloc(a, dim = 3, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 203
+ if (any(r /= 0)) stop 204
+ r = minloc(a, dim = 4, mask = m)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 205
+ end subroutine
+end subroutine
