https://gcc.gnu.org/g:b7afa5b5ce5b3a5cfffea2ab27bbbf261a249edf
commit b7afa5b5ce5b3a5cfffea2ab27bbbf261a249edf
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Thu Oct 3 15:57:50 2024 +0200
fortran: Evaluate once BACK argument of MINLOC/MAXLOC with DIM [pr90608]
Evaluate the BACK argument of MINLOC/MAXLOC once before the
scalarization loops in the case where the DIM argument is present.
This is a follow-up to r15-1994-ga55d24b3cf7f4d07492bb8e6fcee557175b47ea3
which added knowledge of BACK to the scalarizer, to
r15-2701-ga10436a8404ad2f0cc5aa4d6a0cc850abe5ef49e which removed it to
handle it out of scalarization instead, and to more immediate previous
patches that added support for MINLOC/MAXLOC with DIM. The recent
support for MINLOC/MAXLOC with DIM introduced nested loops, which made
the evaluation of BACK (removed from the scalarizer knowledge by previous
patches) wrapped in a loop, so possibly executed more than once. This
change adds BACK to the scalarization chain if MINLOC/MAXLOC will use
nested loops, so that it is evaluated by the scalarizer only once before
the outermost loop in that case.
PR fortran/90608
gcc/fortran/ChangeLog:
* trans-intrinsic.cc
(walk_inline_intrinsic_minmaxloc): Add a scalar element for BACK as
first item of the list if BACK is present and there will be nested
loops.
(gfc_conv_intrinsic_minmaxloc): Evaluate BACK using an inherited
scalarization chain if there is a nested loop.
gcc/testsuite/ChangeLog:
* gfortran.dg/maxloc_8.f90: New test.
* gfortran.dg/minloc_9.f90: New test.
Diff:
---
gcc/fortran/trans-intrinsic.cc | 21 +-
gcc/testsuite/gfortran.dg/maxloc_8.f90 | 349 +++++++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/minloc_9.f90 | 349 +++++++++++++++++++++++++++++++++
3 files changed, 717 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 44bb87dbbfe0..254b05686c27 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -5594,7 +5594,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
&& maskexpr->symtree->n.sym->attr.optional;
backexpr = back_arg->expr;
- gfc_init_se (&backse, NULL);
+ gfc_init_se (&backse, nested_loop ? se : nullptr);
if (backexpr == nullptr)
back = logical_false_node;
else if (maybe_absent_optional_variable (backexpr))
@@ -11885,10 +11885,13 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr
*expr ATTRIBUTE_UNUSED)
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_actual_arglist *kind_arg = mask_arg->next;
+ gfc_actual_arglist *back_arg = kind_arg->next;
gfc_expr *array = array_arg->expr;
gfc_expr *dim = dim_arg->expr;
gfc_expr *mask = mask_arg->expr;
+ gfc_expr *back = back_arg->expr;
if (dim == nullptr)
return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
@@ -11916,7 +11919,21 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr
*expr ATTRIBUTE_UNUSED)
chain. */
int dim_val = mpz_get_si (dim->value.integer) - 1;
gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val);
- tail->next = ss;
+
+ if (back && array->rank > 1)
+ {
+ /* If there are nested scalarization loops, include BACK in the
+ scalarization chains to avoid evaluating it multiple times in a loop.
+ Otherwise, prefer to handle it outside of scalarization. */
+ gfc_ss *back_ss = gfc_get_scalar_ss (ss, back);
+ back_ss->info->type = GFC_SS_REFERENCE;
+ if (maybe_absent_optional_variable (back))
+ back_ss->info->can_be_null_ref = true;
+
+ tail->next = back_ss;
+ }
+ else
+ tail->next = ss;
if (scalar_mask)
{
diff --git a/gcc/testsuite/gfortran.dg/maxloc_8.f90
b/gcc/testsuite/gfortran.dg/maxloc_8.f90
new file mode 100644
index 000000000000..21bc4591235a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/maxloc_8.f90
@@ -0,0 +1,349 @@
+! { dg-do run }
+!
+! PR fortran/90608
+! Check that the evaluation of MAXLOC's BACK argument is made only once
+! before the scalarization loops, when the DIM argument is present.
+
+program p
+ 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 :: calls_count = 0
+ call check_int_const_shape_rank_3
+ call check_int_const_shape_rank_3_scalar_mask
+ call check_int_const_shape_rank_3_optional_mask_present
+ call check_int_const_shape_rank_3_optional_mask_absent
+ call check_int_const_shape_rank_3_array_mask
+ call check_int_const_shape_empty_4
+ call check_int_alloc_rank_3
+ call check_int_alloc_rank_3_scalar_mask
+ call check_int_alloc_rank_3_array_mask
+ call check_int_alloc_empty_4
+ call check_real_const_shape_rank_3
+ call check_real_const_shape_rank_3_scalar_mask
+ call check_real_const_shape_rank_3_optional_mask_present
+ call check_real_const_shape_rank_3_optional_mask_absent
+ call check_real_const_shape_rank_3_array_mask
+ call check_real_const_shape_empty_4
+ call check_real_alloc_rank_3
+ call check_real_alloc_rank_3_scalar_mask
+ call check_real_alloc_rank_3_array_mask
+ call check_real_alloc_empty_4
+contains
+ function get_scalar_false()
+ logical :: get_scalar_false
+ calls_count = calls_count + 1
+ get_scalar_false = .false.
+ end function
+ subroutine check_int_const_shape_rank_3()
+ integer :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ calls_count = 0
+ r = maxloc(a, dim = 1, back = get_scalar_false())
+ if (calls_count /= 1) error stop 12
+ r = maxloc(a, dim = 2, back = get_scalar_false())
+ if (calls_count /= 2) error stop 15
+ r = maxloc(a, dim = 3, back = get_scalar_false())
+ if (calls_count /= 3) error stop 18
+ end subroutine
+ subroutine check_int_const_shape_rank_3_scalar_mask()
+ integer :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ calls_count = 0
+ ! We only check the case of a .true. mask.
+ ! If the mask is .false., the back argument is not necessary to deduce
+ ! the value returned by maxloc, so the compiler is free to elide it,
+ ! and the value of calls_count is undefined in that case.
+ r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false())
+ if (calls_count /= 1) error stop 22
+ r = maxloc(a, dim = 2, mask = .true., back = get_scalar_false())
+ if (calls_count /= 2) error stop 25
+ r = maxloc(a, dim = 3, mask = .true., back = get_scalar_false())
+ if (calls_count /= 3) error stop 28
+ end subroutine
+ subroutine call_maxloc_int(r, a, m, b)
+ integer :: a(:,:,:)
+ logical, optional :: m(:,:,:)
+ logical, optional :: b
+ integer, allocatable :: r(:,:)
+ r = maxloc(a, dim = 2, mask = m, back = b)
+ end subroutine
+ subroutine check_int_const_shape_rank_3_optional_mask_present()
+ integer :: a(3,4,5)
+ logical :: m(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ m = reshape(mask60, shape(m))
+ calls_count = 0
+ call call_maxloc_int(r, a, m, get_scalar_false())
+ if (calls_count /= 1) error stop 45
+ end subroutine
+ subroutine check_int_const_shape_rank_3_optional_mask_absent()
+ integer :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ calls_count = 0
+ call call_maxloc_int(r, a, b = get_scalar_false())
+ if (calls_count /= 1) error stop 55
+ end subroutine
+ subroutine check_int_const_shape_rank_3_array_mask()
+ integer :: a(3,4,5)
+ logical :: m(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ m = reshape(mask60, shape(m))
+ calls_count = 0
+ r = maxloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 62
+ r = maxloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 65
+ r = maxloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 68
+ 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))
+ calls_count = 0
+ r = maxloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 72
+ r = maxloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 74
+ r = maxloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 76
+ r = maxloc(a, dim = 4, mask = m, back = get_scalar_false())
+ if (calls_count /= 4) error stop 72
+ end subroutine
+ subroutine check_int_alloc_rank_3()
+ integer, allocatable :: a(:,:,:)
+ integer, allocatable :: r(:,:)
+ allocate(a(3,4,5))
+ a(:,:,:) = reshape(data60, shape(a))
+ calls_count = 0
+ r = maxloc(a, dim = 1, back = get_scalar_false())
+ if (calls_count /= 1) error stop 82
+ r = maxloc(a, dim = 2, back = get_scalar_false())
+ if (calls_count /= 2) error stop 85
+ r = maxloc(a, dim = 3, back = get_scalar_false())
+ if (calls_count /= 3) error stop 88
+ end subroutine
+ subroutine check_int_alloc_rank_3_scalar_mask()
+ integer, allocatable :: a(:,:,:)
+ integer, allocatable :: r(:,:)
+ allocate(a(3,4,5))
+ a(:,:,:) = reshape(data60, shape(a))
+ calls_count = 0
+ ! We only check the case of a .true. mask.
+ ! If the mask is .false., the back argument is not necessary to deduce
+ ! the value returned by maxloc, so the compiler is free to elide it,
+ ! and the value of calls_count is undefined in that case.
+ r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false())
+ if (calls_count /= 1) error stop 92
+ r = maxloc(a, dim = 2, mask = .true., back = get_scalar_false())
+ if (calls_count /= 2) error stop 95
+ r = maxloc(a, dim = 3, mask = .true., back = get_scalar_false())
+ if (calls_count /= 3) error stop 98
+ end subroutine
+ subroutine check_int_alloc_rank_3_array_mask()
+ 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))
+ calls_count = 0
+ r = maxloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 102
+ r = maxloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 105
+ r = maxloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 108
+ 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))
+ calls_count = 0
+ r = maxloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 112
+ r = maxloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 114
+ r = maxloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 116
+ r = maxloc(a, dim = 4, mask = m, back = get_scalar_false())
+ if (calls_count /= 4) error stop 118
+ 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))
+ calls_count = 0
+ r = maxloc(a, dim = 1, back = get_scalar_false())
+ if (calls_count /= 1) error stop 122
+ r = maxloc(a, dim = 2, back = get_scalar_false())
+ if (calls_count /= 2) error stop 125
+ r = maxloc(a, dim = 3, back = get_scalar_false())
+ if (calls_count /= 3) error stop 128
+ end subroutine
+ subroutine check_real_const_shape_rank_3_scalar_mask()
+ real :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape((/ real:: data60 /), shape(a))
+ calls_count = 0
+ ! We only check the case of a .true. mask.
+ ! If the mask is .false., the back argument is not necessary to deduce
+ ! the value returned by maxloc, so the compiler is free to elide it,
+ ! and the value of calls_count is undefined in that case.
+ r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false())
+ if (calls_count /= 1) error stop 132
+ r = maxloc(a, dim = 2, mask = .true., back = get_scalar_false())
+ if (calls_count /= 2) error stop 135
+ r = maxloc(a, dim = 3, mask = .true., back = get_scalar_false())
+ if (calls_count /= 3) error stop 138
+ end subroutine
+ subroutine check_real_const_shape_rank_3_array_mask()
+ real :: a(3,4,5)
+ logical :: m(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape((/ real:: data60 /), shape(a))
+ m = reshape(mask60, shape(m))
+ calls_count = 0
+ r = maxloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 142
+ r = maxloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 145
+ r = maxloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 148
+ end subroutine
+ subroutine call_maxloc_real(r, a, m, b)
+ real :: a(:,:,:)
+ logical, optional :: m(:,:,:)
+ logical, optional :: b
+ integer, allocatable :: r(:,:)
+ r = maxloc(a, dim = 2, mask = m, back = b)
+ end subroutine
+ subroutine check_real_const_shape_rank_3_optional_mask_present()
+ real :: a(3,4,5)
+ logical :: m(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape((/ real:: data60 /), shape(a))
+ m = reshape(mask60, shape(m))
+ calls_count = 0
+ call call_maxloc_real(r, a, m, get_scalar_false())
+ if (calls_count /= 1) error stop 155
+ end subroutine
+ subroutine check_real_const_shape_rank_3_optional_mask_absent()
+ real :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape((/ real:: data60 /), shape(a))
+ calls_count = 0
+ call call_maxloc_real(r, a, b = get_scalar_false())
+ if (calls_count /= 1) error stop 165
+ 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))
+ calls_count = 0
+ r = maxloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 172
+ r = maxloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 174
+ r = maxloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 176
+ r = maxloc(a, dim = 4, mask = m, back = get_scalar_false())
+ if (calls_count /= 4) error stop 178
+ 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))
+ calls_count = 0
+ r = maxloc(a, dim = 1, back = get_scalar_false())
+ if (calls_count /= 1) error stop 182
+ r = maxloc(a, dim = 2, back = get_scalar_false())
+ if (calls_count /= 2) error stop 185
+ r = maxloc(a, dim = 3, back = get_scalar_false())
+ if (calls_count /= 3) error stop 188
+ end subroutine
+ subroutine check_real_alloc_rank_3_scalar_mask()
+ real, allocatable :: a(:,:,:)
+ integer, allocatable :: r(:,:)
+ allocate(a(3,4,5))
+ a(:,:,:) = reshape((/ real:: data60 /), shape(a))
+ calls_count = 0
+ ! We only check the case of a .true. mask.
+ ! If the mask is .false., the back argument is not necessary to deduce
+ ! the value returned by maxloc, so the compiler is free to elide it,
+ ! and the value of calls_count is undefined in that case.
+ r = maxloc(a, dim = 1, mask = .true., back = get_scalar_false())
+ if (calls_count /= 1) error stop 192
+ r = maxloc(a, dim = 2, mask = .true., back = get_scalar_false())
+ if (calls_count /= 2) error stop 195
+ r = maxloc(a, dim = 3, mask = .true., back = get_scalar_false())
+ if (calls_count /= 3) error stop 198
+ end subroutine
+ subroutine check_real_alloc_rank_3_array_mask()
+ 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))
+ calls_count = 0
+ r = maxloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 202
+ r = maxloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 205
+ r = maxloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 208
+ 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))
+ calls_count = 0
+ r = maxloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 212
+ r = maxloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 214
+ r = maxloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 216
+ r = maxloc(a, dim = 4, mask = m, back = get_scalar_false())
+ if (calls_count /= 4) error stop 218
+ end subroutine
+end program p
diff --git a/gcc/testsuite/gfortran.dg/minloc_9.f90
b/gcc/testsuite/gfortran.dg/minloc_9.f90
new file mode 100644
index 000000000000..8037c549d78d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/minloc_9.f90
@@ -0,0 +1,349 @@
+! { dg-do run }
+!
+! PR fortran/90608
+! Check that the evaluation of MINLOC's BACK argument is made only once
+! before the scalarization loops, when the DIM argument is present.
+
+program p
+ 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 :: calls_count = 0
+ call check_int_const_shape_rank_3
+ call check_int_const_shape_rank_3_scalar_mask
+ call check_int_const_shape_rank_3_optional_mask_present
+ call check_int_const_shape_rank_3_optional_mask_absent
+ call check_int_const_shape_rank_3_array_mask
+ call check_int_const_shape_empty_4
+ call check_int_alloc_rank_3
+ call check_int_alloc_rank_3_scalar_mask
+ call check_int_alloc_rank_3_array_mask
+ call check_int_alloc_empty_4
+ call check_real_const_shape_rank_3
+ call check_real_const_shape_rank_3_scalar_mask
+ call check_real_const_shape_rank_3_optional_mask_present
+ call check_real_const_shape_rank_3_optional_mask_absent
+ call check_real_const_shape_rank_3_array_mask
+ call check_real_const_shape_empty_4
+ call check_real_alloc_rank_3
+ call check_real_alloc_rank_3_scalar_mask
+ call check_real_alloc_rank_3_array_mask
+ call check_real_alloc_empty_4
+contains
+ function get_scalar_false()
+ logical :: get_scalar_false
+ calls_count = calls_count + 1
+ get_scalar_false = .false.
+ end function
+ subroutine check_int_const_shape_rank_3()
+ integer :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ calls_count = 0
+ r = minloc(a, dim = 1, back = get_scalar_false())
+ if (calls_count /= 1) error stop 12
+ r = minloc(a, dim = 2, back = get_scalar_false())
+ if (calls_count /= 2) error stop 15
+ r = minloc(a, dim = 3, back = get_scalar_false())
+ if (calls_count /= 3) error stop 18
+ end subroutine
+ subroutine check_int_const_shape_rank_3_scalar_mask()
+ integer :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ calls_count = 0
+ ! We only check the case of a .true. mask.
+ ! If the mask is .false., the back argument is not necessary to deduce
+ ! the value returned by minloc, so the compiler is free to elide it,
+ ! and the value of calls_count is undefined in that case.
+ r = minloc(a, dim = 1, mask = .true., back = get_scalar_false())
+ if (calls_count /= 1) error stop 22
+ r = minloc(a, dim = 2, mask = .true., back = get_scalar_false())
+ if (calls_count /= 2) error stop 25
+ r = minloc(a, dim = 3, mask = .true., back = get_scalar_false())
+ if (calls_count /= 3) error stop 28
+ end subroutine
+ subroutine call_minloc_int(r, a, m, b)
+ integer :: a(:,:,:)
+ logical, optional :: m(:,:,:)
+ logical, optional :: b
+ integer, allocatable :: r(:,:)
+ r = minloc(a, dim = 2, mask = m, back = b)
+ end subroutine
+ subroutine check_int_const_shape_rank_3_optional_mask_present()
+ integer :: a(3,4,5)
+ logical :: m(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ m = reshape(mask60, shape(m))
+ calls_count = 0
+ call call_minloc_int(r, a, m, get_scalar_false())
+ if (calls_count /= 1) error stop 45
+ end subroutine
+ subroutine check_int_const_shape_rank_3_optional_mask_absent()
+ integer :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ calls_count = 0
+ call call_minloc_int(r, a, b = get_scalar_false())
+ if (calls_count /= 1) error stop 55
+ end subroutine
+ subroutine check_int_const_shape_rank_3_array_mask()
+ integer :: a(3,4,5)
+ logical :: m(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ m = reshape(mask60, shape(m))
+ calls_count = 0
+ r = minloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 62
+ r = minloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 65
+ r = minloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 68
+ 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))
+ calls_count = 0
+ r = minloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 72
+ r = minloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 74
+ r = minloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 76
+ r = minloc(a, dim = 4, mask = m, back = get_scalar_false())
+ if (calls_count /= 4) error stop 72
+ end subroutine
+ subroutine check_int_alloc_rank_3()
+ integer, allocatable :: a(:,:,:)
+ integer, allocatable :: r(:,:)
+ allocate(a(3,4,5))
+ a(:,:,:) = reshape(data60, shape(a))
+ calls_count = 0
+ r = minloc(a, dim = 1, back = get_scalar_false())
+ if (calls_count /= 1) error stop 82
+ r = minloc(a, dim = 2, back = get_scalar_false())
+ if (calls_count /= 2) error stop 85
+ r = minloc(a, dim = 3, back = get_scalar_false())
+ if (calls_count /= 3) error stop 88
+ end subroutine
+ subroutine check_int_alloc_rank_3_scalar_mask()
+ integer, allocatable :: a(:,:,:)
+ integer, allocatable :: r(:,:)
+ allocate(a(3,4,5))
+ a(:,:,:) = reshape(data60, shape(a))
+ calls_count = 0
+ ! We only check the case of a .true. mask.
+ ! If the mask is .false., the back argument is not necessary to deduce
+ ! the value returned by minloc, so the compiler is free to elide it,
+ ! and the value of calls_count is undefined in that case.
+ r = minloc(a, dim = 1, mask = .true., back = get_scalar_false())
+ if (calls_count /= 1) error stop 92
+ r = minloc(a, dim = 2, mask = .true., back = get_scalar_false())
+ if (calls_count /= 2) error stop 95
+ r = minloc(a, dim = 3, mask = .true., back = get_scalar_false())
+ if (calls_count /= 3) error stop 98
+ end subroutine
+ subroutine check_int_alloc_rank_3_array_mask()
+ 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))
+ calls_count = 0
+ r = minloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 102
+ r = minloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 105
+ r = minloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 108
+ 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))
+ calls_count = 0
+ r = minloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 112
+ r = minloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 114
+ r = minloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 116
+ r = minloc(a, dim = 4, mask = m, back = get_scalar_false())
+ if (calls_count /= 4) error stop 118
+ 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))
+ calls_count = 0
+ r = minloc(a, dim = 1, back = get_scalar_false())
+ if (calls_count /= 1) error stop 122
+ r = minloc(a, dim = 2, back = get_scalar_false())
+ if (calls_count /= 2) error stop 125
+ r = minloc(a, dim = 3, back = get_scalar_false())
+ if (calls_count /= 3) error stop 128
+ end subroutine
+ subroutine check_real_const_shape_rank_3_scalar_mask()
+ real :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape((/ real:: data60 /), shape(a))
+ calls_count = 0
+ ! We only check the case of a .true. mask.
+ ! If the mask is .false., the back argument is not necessary to deduce
+ ! the value returned by minloc, so the compiler is free to elide it,
+ ! and the value of calls_count is undefined in that case.
+ r = minloc(a, dim = 1, mask = .true., back = get_scalar_false())
+ if (calls_count /= 1) error stop 132
+ r = minloc(a, dim = 2, mask = .true., back = get_scalar_false())
+ if (calls_count /= 2) error stop 135
+ r = minloc(a, dim = 3, mask = .true., back = get_scalar_false())
+ if (calls_count /= 3) error stop 138
+ end subroutine
+ subroutine check_real_const_shape_rank_3_array_mask()
+ real :: a(3,4,5)
+ logical :: m(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape((/ real:: data60 /), shape(a))
+ m = reshape(mask60, shape(m))
+ calls_count = 0
+ r = minloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 142
+ r = minloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 145
+ r = minloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 148
+ end subroutine
+ subroutine call_minloc_real(r, a, m, b)
+ real :: a(:,:,:)
+ logical, optional :: m(:,:,:)
+ logical, optional :: b
+ integer, allocatable :: r(:,:)
+ r = minloc(a, dim = 2, mask = m, back = b)
+ end subroutine
+ subroutine check_real_const_shape_rank_3_optional_mask_present()
+ real :: a(3,4,5)
+ logical :: m(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape((/ real:: data60 /), shape(a))
+ m = reshape(mask60, shape(m))
+ calls_count = 0
+ call call_minloc_real(r, a, m, get_scalar_false())
+ if (calls_count /= 1) error stop 155
+ end subroutine
+ subroutine check_real_const_shape_rank_3_optional_mask_absent()
+ real :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape((/ real:: data60 /), shape(a))
+ calls_count = 0
+ call call_minloc_real(r, a, b = get_scalar_false())
+ if (calls_count /= 1) error stop 165
+ 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))
+ calls_count = 0
+ r = minloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 172
+ r = minloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 174
+ r = minloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 176
+ r = minloc(a, dim = 4, mask = m, back = get_scalar_false())
+ if (calls_count /= 4) error stop 178
+ 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))
+ calls_count = 0
+ r = minloc(a, dim = 1, back = get_scalar_false())
+ if (calls_count /= 1) error stop 182
+ r = minloc(a, dim = 2, back = get_scalar_false())
+ if (calls_count /= 2) error stop 185
+ r = minloc(a, dim = 3, back = get_scalar_false())
+ if (calls_count /= 3) error stop 188
+ end subroutine
+ subroutine check_real_alloc_rank_3_scalar_mask()
+ real, allocatable :: a(:,:,:)
+ integer, allocatable :: r(:,:)
+ allocate(a(3,4,5))
+ a(:,:,:) = reshape((/ real:: data60 /), shape(a))
+ calls_count = 0
+ ! We only check the case of a .true. mask.
+ ! If the mask is .false., the back argument is not necessary to deduce
+ ! the value returned by minloc, so the compiler is free to elide it,
+ ! and the value of calls_count is undefined in that case.
+ r = minloc(a, dim = 1, mask = .true., back = get_scalar_false())
+ if (calls_count /= 1) error stop 192
+ r = minloc(a, dim = 2, mask = .true., back = get_scalar_false())
+ if (calls_count /= 2) error stop 195
+ r = minloc(a, dim = 3, mask = .true., back = get_scalar_false())
+ if (calls_count /= 3) error stop 198
+ end subroutine
+ subroutine check_real_alloc_rank_3_array_mask()
+ 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))
+ calls_count = 0
+ r = minloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 202
+ r = minloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 205
+ r = minloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 208
+ 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))
+ calls_count = 0
+ r = minloc(a, dim = 1, mask = m, back = get_scalar_false())
+ if (calls_count /= 1) error stop 212
+ r = minloc(a, dim = 2, mask = m, back = get_scalar_false())
+ if (calls_count /= 2) error stop 214
+ r = minloc(a, dim = 3, mask = m, back = get_scalar_false())
+ if (calls_count /= 3) error stop 216
+ r = minloc(a, dim = 4, mask = m, back = get_scalar_false())
+ if (calls_count /= 4) error stop 218
+ end subroutine
+end program p
