diff mbox series

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

Message ID 20241014150816.315478-6-morin-mikael@orange.fr
State New
Headers show
Series fortran: Inline MINLOC/MAXLOC with DIM [PR90608] | expand

Commit Message

Mikael Morin Oct. 14, 2024, 3:08 p.m. UTC 
From: Mikael Morin <mikael@gcc.gnu.org>

Bootstrapped and regression-tested on x86_64-pc-linux-gnu.
OK for master?

-- >8 --

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.
---
 gcc/fortran/trans-intrinsic.cc             |  96 ++--
 gcc/testsuite/gfortran.dg/minmaxloc_21.f90 | 572 +++++++++++++++++++++
 2 files changed, 625 insertions(+), 43 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/minmaxloc_21.f90
diff mbox series

Patch

diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 0ac3d7fe3a1..b77183ab11e 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 - 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
@@ -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 00000000000..f31335cc5e6
--- /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 /))) 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