https://gcc.gnu.org/g:40122a405386a8b67c11bbaad523ffce5c1c7855
commit 40122a405386a8b67c11bbaad523ffce5c1c7855
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Fri Aug 2 14:24:34 2024 +0200
fortran: Support optional dummy as BACK argument of MINLOC/MAXLOC.
Protect the evaluation of BACK with a check that the reference is non-null
in case the expression is an optional dummy, in the inline code generated
for MINLOC and MAXLOC.
This change contains a revert of the non-testsuite part of commit
r15-1994-ga55d24b3cf7f4d07492bb8e6fcee557175b47ea3, which factored the
evaluation of BACK out of the loop using the scalarizer. It was a bad idea,
because delegating the argument evaluation to the scalarizer makes it
cumbersome to add a null pointer check next to the evaluation.
Instead, evaluate BACK at the beginning, before scalarization, add a check
that the argument is present if necessary, and evaluate the resulting
expression to a variable, before using the variable in the inline code.
gcc/fortran/ChangeLog:
* trans-intrinsic.cc (maybe_absent_optional_variable): New function.
(gfc_conv_intrinsic_minmaxloc): Remove BACK from scalarization and
evaluate it before. Add a check that BACK is not null if the
expression is an optional dummy. Save the resulting expression to a
variable. Use the variable in the generated inline code.
gcc/testsuite/ChangeLog:
* gfortran.dg/maxloc_6.f90: New test.
* gfortran.dg/minloc_7.f90: New test.
Diff:
---
gcc/fortran/trans-intrinsic.cc | 83 ++++++--
gcc/testsuite/gfortran.dg/maxloc_6.f90 | 366 +++++++++++++++++++++++++++++++++
gcc/testsuite/gfortran.dg/minloc_7.f90 | 366 +++++++++++++++++++++++++++++++++
3 files changed, 801 insertions(+), 14 deletions(-)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 180d0d7a88c6..150cb9ff963b 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -5209,6 +5209,50 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr *
expr)
}
+/* Tells whether the expression E is a reference to an optional variable whose
+ presence is not known at compile time. Those are variable references
without
+ subreference; if there is a subreference, we can assume the variable is
+ present. We have to special case full arrays, which we represent with a
fake
+ "full" reference, and class descriptors for which a reference to data is not
+ really a subreference. */
+
+bool
+maybe_absent_optional_variable (gfc_expr *e)
+{
+ if (!(e && e->expr_type == EXPR_VARIABLE))
+ return false;
+
+ gfc_symbol *sym = e->symtree->n.sym;
+ if (!sym->attr.optional)
+ return false;
+
+ gfc_ref *ref = e->ref;
+ if (ref == nullptr)
+ return true;
+
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.type == AR_FULL
+ && ref->next == nullptr)
+ return true;
+
+ if (!(sym->ts.type == BT_CLASS
+ && ref->type == REF_COMPONENT
+ && ref->u.c.component == CLASS_DATA (sym)))
+ return false;
+
+ gfc_ref *next_ref = ref->next;
+ if (next_ref == nullptr)
+ return true;
+
+ if (next_ref->type == REF_ARRAY
+ && next_ref->u.ar.type == AR_FULL
+ && next_ref->next == nullptr)
+ return true;
+
+ return false;
+}
+
+
/* Remove unneeded kind= argument from actual argument list when the
result conversion is dealt with in a different place. */
@@ -5321,11 +5365,11 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
tree nonempty;
tree lab1, lab2;
tree b_if, b_else;
+ tree back;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
gfc_ss *arrayss;
gfc_ss *maskss;
- gfc_ss *backss;
gfc_se arrayse;
gfc_se maskse;
gfc_expr *arrayexpr;
@@ -5391,10 +5435,29 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
&& maskexpr->symtree->n.sym->attr.dummy
&& maskexpr->symtree->n.sym->attr.optional;
backexpr = actual->next->next->expr;
- if (backexpr)
- backss = gfc_get_scalar_ss (gfc_ss_terminator, backexpr);
+
+ gfc_init_se (&backse, NULL);
+ if (backexpr == nullptr)
+ back = logical_false_node;
+ else if (maybe_absent_optional_variable (backexpr))
+ {
+ /* This should have been checked already by
+ maybe_absent_optional_variable. */
+ gcc_checking_assert (backexpr->expr_type == EXPR_VARIABLE);
+
+ gfc_conv_expr (&backse, backexpr);
+ tree present = gfc_conv_expr_present (backexpr->symtree->n.sym, false);
+ back = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ logical_type_node, present, backse.expr);
+ }
else
- backss = nullptr;
+ {
+ gfc_conv_expr (&backse, backexpr);
+ back = backse.expr;
+ }
+ gfc_add_block_to_block (&se->pre, &backse.pre);
+ back = gfc_evaluate_now_loc (input_location, back, &se->pre);
+ gfc_add_block_to_block (&se->pre, &backse.post);
nonempty = NULL;
if (maskexpr && maskexpr->rank != 0)
@@ -5455,9 +5518,6 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
if (maskss)
gfc_add_ss_to_loop (&loop, maskss);
- if (backss)
- gfc_add_ss_to_loop (&loop, backss);
-
gfc_add_ss_to_loop (&loop, arrayss);
/* Initialize the loop. */
@@ -5543,11 +5603,6 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
- gfc_init_se (&backse, NULL);
- backse.ss = backss;
- gfc_conv_expr_val (&backse, backexpr);
- gfc_add_block_to_block (&block, &backse.pre);
-
/* We do the following if this is a more extreme value. */
gfc_start_block (&ifblock);
@@ -5608,7 +5663,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
elsebody2 = gfc_finish_block (&elseblock);
tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
- backse.expr, ifbody2, elsebody2);
+ back, ifbody2, elsebody2);
gfc_add_expr_to_block (&block, tmp);
}
@@ -5707,7 +5762,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
elsebody2 = gfc_finish_block (&elseblock);
tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
- backse.expr, ifbody2, elsebody2);
+ back, ifbody2, elsebody2);
}
gfc_add_expr_to_block (&block, tmp);
diff --git a/gcc/testsuite/gfortran.dg/maxloc_6.f90
b/gcc/testsuite/gfortran.dg/maxloc_6.f90
new file mode 100644
index 000000000000..d5439b8dca04
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/maxloc_6.f90
@@ -0,0 +1,366 @@
+! { dg-do run }
+!
+! Check that the inline implementation of MAXLOC correctly supports indirect
+! MASK, that is a MASK expression that is itself an optional variable.
+
+program p
+ implicit none
+ integer, parameter :: data(*) = (/ 3, 7, 1, 0, 7, 0, 3, 5, 3, 0 /)
+ logical, parameter :: mask(*) = (/ .true. , .false., .true., .true. , &
+ & .false., .true. , .true., .false., &
+ & .true. , .true. /)
+ call check_int_const_shape_absent_back
+ call check_int_const_shape_false_back
+ call check_int_const_shape_true_back
+ call check_int_const_shape_scalar_mask_absent_back
+ call check_int_const_shape_scalar_mask_false_back
+ call check_int_const_shape_scalar_mask_true_back
+ call check_int_assumed_shape_absent_back
+ call check_int_assumed_shape_false_back
+ call check_int_assumed_shape_true_back
+ call check_int_assumed_shape_scalar_mask_absent_back
+ call check_int_assumed_shape_scalar_mask_false_back
+ call check_int_assumed_shape_scalar_mask_true_back
+ call check_int_func_absent_back
+ call check_int_func_false_back
+ call check_int_func_true_back
+ call check_int_func_scalar_mask_absent_back
+ call check_int_func_scalar_mask_false_back
+ call check_int_func_scalar_mask_true_back
+ call check_int_const_shape_array_mask_absent_back
+ call check_int_const_shape_array_mask_false_back
+ call check_int_const_shape_array_mask_true_back
+ call check_int_assumed_shape_array_mask_absent_back
+ call check_int_assumed_shape_array_mask_false_back
+ call check_int_assumed_shape_array_mask_true_back
+ call check_real_const_shape_absent_back
+ call check_real_const_shape_false_back
+ call check_real_const_shape_true_back
+ call check_real_const_shape_scalar_mask_absent_back
+ call check_real_const_shape_scalar_mask_false_back
+ call check_real_const_shape_scalar_mask_true_back
+ call check_real_assumed_shape_absent_back
+ call check_real_assumed_shape_false_back
+ call check_real_assumed_shape_true_back
+ call check_real_assumed_shape_scalar_mask_absent_back
+ call check_real_assumed_shape_scalar_mask_false_back
+ call check_real_assumed_shape_scalar_mask_true_back
+contains
+ subroutine call_maxloc_int_const_shape(r, a, b)
+ integer :: r, a(10)
+ logical, optional :: b
+ r = maxloc(a, dim = 1, back = b)
+ end subroutine
+ subroutine check_int_const_shape_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_const_shape(r, a)
+ if (r /= 2) stop 9
+ end subroutine
+ subroutine check_int_const_shape_false_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_const_shape(r, a, .false.)
+ if (r /= 2) stop 16
+ end subroutine
+ subroutine check_int_const_shape_true_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_const_shape(r, a, .true.)
+ if (r /= 5) stop 23
+ end subroutine
+ subroutine call_maxloc_int_const_shape_scalar_mask(r, a, m, b)
+ integer :: r, a(10)
+ logical :: m
+ logical, optional :: b
+ r = maxloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_int_const_shape_scalar_mask_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_const_shape_scalar_mask(r, a, .true.)
+ if (r /= 2) stop 30
+ end subroutine
+ subroutine check_int_const_shape_scalar_mask_false_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_const_shape_scalar_mask(r, a, .true., .false.)
+ if (r /= 2) stop 37
+ end subroutine
+ subroutine check_int_const_shape_scalar_mask_true_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_const_shape_scalar_mask(r, a, .true., .true.)
+ if (r /= 5) stop 44
+ end subroutine
+ subroutine call_maxloc_int_assumed_shape(r, a, b)
+ integer :: r, a(:)
+ logical, optional :: b
+ r = maxloc(a, dim = 1, back = b)
+ end subroutine
+ subroutine check_int_assumed_shape_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_assumed_shape(r, a)
+ if (r /= 2) stop 51
+ end subroutine
+ subroutine check_int_assumed_shape_false_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_assumed_shape(r, a, .false.)
+ if (r /= 2) stop 58
+ end subroutine
+ subroutine check_int_assumed_shape_true_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_assumed_shape(r, a, .true.)
+ if (r /= 5) stop 65
+ end subroutine
+ subroutine call_maxloc_int_assumed_shape_scalar_mask(r, a, m, b)
+ integer :: r, a(:)
+ logical :: m
+ logical, optional :: b
+ r = maxloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_int_assumed_shape_scalar_mask_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_assumed_shape_scalar_mask(r, a, .true.)
+ if (r /= 2) stop 72
+ end subroutine
+ subroutine check_int_assumed_shape_scalar_mask_false_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_assumed_shape_scalar_mask(r, a, .true., .false.)
+ if (r /= 2) stop 79
+ end subroutine
+ subroutine check_int_assumed_shape_scalar_mask_true_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_assumed_shape_scalar_mask(r, a, .true., .true.)
+ if (r /= 5) stop 86
+ end subroutine
+ function id(a) result(r)
+ integer, dimension(:) :: a
+ integer, dimension(size(a, dim = 1)) :: r
+ r = a
+ end function
+ subroutine call_maxloc_int_func(r, a, b)
+ integer :: r, a(:)
+ logical, optional :: b
+ r = maxloc(id(a) + 1, dim = 1, back = b)
+ end subroutine
+ subroutine check_int_func_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_func(r, a)
+ if (r /= 2) stop 93
+ end subroutine
+ subroutine check_int_func_false_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_func(r, a, .false.)
+ if (r /= 2) stop 100
+ end subroutine
+ subroutine check_int_func_true_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_func(r, a, .true.)
+ if (r /= 5) stop 107
+ end subroutine
+ subroutine call_maxloc_int_func_scalar_mask(r, a, m, b)
+ integer :: r, a(:)
+ logical :: m
+ logical, optional :: b
+ r = maxloc(id(a) + 1, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_int_func_scalar_mask_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_func_scalar_mask(r, a, .true.)
+ if (r /= 2) stop 114
+ end subroutine
+ subroutine check_int_func_scalar_mask_false_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_func_scalar_mask(r, a, .true., .false.)
+ if (r /= 2) stop 121
+ end subroutine
+ subroutine check_int_func_scalar_mask_true_back
+ integer :: r, a(10)
+ a = data
+ call call_maxloc_int_func_scalar_mask(r, a, .true., .true.)
+ if (r /= 5) stop 128
+ end subroutine
+ subroutine call_maxloc_int_const_shape_array_mask(r, a, m, b)
+ integer :: r, a(10)
+ logical :: m(10)
+ logical, optional :: b
+ r = maxloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_int_const_shape_array_mask_absent_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_maxloc_int_const_shape_array_mask(r, a, m)
+ if (r /= 1) stop 135
+ end subroutine
+ subroutine check_int_const_shape_array_mask_false_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_maxloc_int_const_shape_array_mask(r, a, m, .false.)
+ if (r /= 1) stop 142
+ end subroutine
+ subroutine check_int_const_shape_array_mask_true_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_maxloc_int_const_shape_array_mask(r, a, m, .true.)
+ if (r /= 9) stop 149
+ end subroutine
+ subroutine call_maxloc_int_assumed_shape_array_mask(r, a, m, b)
+ integer :: r, a(:)
+ logical :: m(:)
+ logical, optional :: b
+ r = maxloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_int_assumed_shape_array_mask_absent_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_maxloc_int_assumed_shape_array_mask(r, a, m)
+ if (r /= 1) stop 156
+ end subroutine
+ subroutine check_int_assumed_shape_array_mask_false_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_maxloc_int_assumed_shape_array_mask(r, a, m, .false.)
+ if (r /= 1) stop 163
+ end subroutine
+ subroutine check_int_assumed_shape_array_mask_true_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_maxloc_int_assumed_shape_array_mask(r, a, m, .true.)
+ if (r /= 9) stop 170
+ end subroutine
+ subroutine call_maxloc_real_const_shape(r, a, b)
+ integer :: r
+ real :: a(10)
+ logical, optional :: b
+ r = maxloc(a, dim = 1, back = b)
+ end subroutine
+ subroutine check_real_const_shape_absent_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_const_shape(r, a)
+ if (r /= 2) stop 177
+ end subroutine
+ subroutine check_real_const_shape_false_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_const_shape(r, a, .false.)
+ if (r /= 2) stop 184
+ end subroutine
+ subroutine check_real_const_shape_true_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_const_shape(r, a, .true.)
+ if (r /= 5) stop 191
+ end subroutine
+ subroutine call_maxloc_real_const_shape_scalar_mask(r, a, m, b)
+ integer :: r
+ real :: a(10)
+ logical :: m
+ logical, optional :: b
+ r = maxloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_real_const_shape_scalar_mask_absent_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_const_shape_scalar_mask(r, a, .true.)
+ if (r /= 2) stop 198
+ end subroutine
+ subroutine check_real_const_shape_scalar_mask_false_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_const_shape_scalar_mask(r, a, .true., .false.)
+ if (r /= 2) stop 205
+ end subroutine
+ subroutine check_real_const_shape_scalar_mask_true_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_const_shape_scalar_mask(r, a, .true., .true.)
+ if (r /= 5) stop 212
+ end subroutine
+ subroutine call_maxloc_real_assumed_shape(r, a, b)
+ integer :: r
+ real :: a(:)
+ logical, optional :: b
+ r = maxloc(a, dim = 1, back = b)
+ end subroutine
+ subroutine check_real_assumed_shape_absent_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_assumed_shape(r, a)
+ if (r /= 2) stop 219
+ end subroutine
+ subroutine check_real_assumed_shape_false_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_assumed_shape(r, a, .false.)
+ if (r /= 2) stop 226
+ end subroutine
+ subroutine check_real_assumed_shape_true_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_assumed_shape(r, a, .true.)
+ if (r /= 5) stop 233
+ end subroutine
+ subroutine call_maxloc_real_assumed_shape_scalar_mask(r, a, m, b)
+ integer :: r
+ real :: a(:)
+ logical :: m
+ logical, optional :: b
+ r = maxloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_real_assumed_shape_scalar_mask_absent_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_assumed_shape_scalar_mask(r, a, .true.)
+ if (r /= 2) stop 240
+ end subroutine
+ subroutine check_real_assumed_shape_scalar_mask_false_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_maxloc_real_assumed_shape_scalar_mask(r, a, .true., .false.)
+ if (r /= 2) stop 247
+ end subroutine
+ subroutine check_real_assumed_shape_scalar_mask_true_back
+ integer :: r
+ real :: a(10)
+ a = data
+ a = (/ real :: data /)
+ call call_maxloc_real_assumed_shape_scalar_mask(r, a, .true., .true.)
+ if (r /= 5) stop 254
+ end subroutine
+end program p
diff --git a/gcc/testsuite/gfortran.dg/minloc_7.f90
b/gcc/testsuite/gfortran.dg/minloc_7.f90
new file mode 100644
index 000000000000..7da77faaa010
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/minloc_7.f90
@@ -0,0 +1,366 @@
+! { dg-do run }
+!
+! Check that the inline implementation of MINLOC correctly supports indirect
+! MASK, that is a MASK expression that is itself an optional variable.
+
+program p
+ implicit none
+ integer, parameter :: data(*) = (/ 6, 2, 8, 9, 2, 9, 6, 4, 6, 9 /)
+ logical, parameter :: mask(*) = (/ .true. , .false., .true., .true. , &
+ & .false., .true. , .true., .false., &
+ & .true. , .true. /)
+ call check_int_const_shape_absent_back
+ call check_int_const_shape_false_back
+ call check_int_const_shape_true_back
+ call check_int_const_shape_scalar_mask_absent_back
+ call check_int_const_shape_scalar_mask_false_back
+ call check_int_const_shape_scalar_mask_true_back
+ call check_int_assumed_shape_absent_back
+ call check_int_assumed_shape_false_back
+ call check_int_assumed_shape_true_back
+ call check_int_assumed_shape_scalar_mask_absent_back
+ call check_int_assumed_shape_scalar_mask_false_back
+ call check_int_assumed_shape_scalar_mask_true_back
+ call check_int_func_absent_back
+ call check_int_func_false_back
+ call check_int_func_true_back
+ call check_int_func_scalar_mask_absent_back
+ call check_int_func_scalar_mask_false_back
+ call check_int_func_scalar_mask_true_back
+ call check_int_const_shape_array_mask_absent_back
+ call check_int_const_shape_array_mask_false_back
+ call check_int_const_shape_array_mask_true_back
+ call check_int_assumed_shape_array_mask_absent_back
+ call check_int_assumed_shape_array_mask_false_back
+ call check_int_assumed_shape_array_mask_true_back
+ call check_real_const_shape_absent_back
+ call check_real_const_shape_false_back
+ call check_real_const_shape_true_back
+ call check_real_const_shape_scalar_mask_absent_back
+ call check_real_const_shape_scalar_mask_false_back
+ call check_real_const_shape_scalar_mask_true_back
+ call check_real_assumed_shape_absent_back
+ call check_real_assumed_shape_false_back
+ call check_real_assumed_shape_true_back
+ call check_real_assumed_shape_scalar_mask_absent_back
+ call check_real_assumed_shape_scalar_mask_false_back
+ call check_real_assumed_shape_scalar_mask_true_back
+contains
+ subroutine call_minloc_int_const_shape(r, a, b)
+ integer :: r, a(10)
+ logical, optional :: b
+ r = minloc(a, dim = 1, back = b)
+ end subroutine
+ subroutine check_int_const_shape_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_const_shape(r, a)
+ if (r /= 2) stop 9
+ end subroutine
+ subroutine check_int_const_shape_false_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_const_shape(r, a, .false.)
+ if (r /= 2) stop 16
+ end subroutine
+ subroutine check_int_const_shape_true_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_const_shape(r, a, .true.)
+ if (r /= 5) stop 23
+ end subroutine
+ subroutine call_minloc_int_const_shape_scalar_mask(r, a, m, b)
+ integer :: r, a(10)
+ logical :: m
+ logical, optional :: b
+ r = minloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_int_const_shape_scalar_mask_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_const_shape_scalar_mask(r, a, .true.)
+ if (r /= 2) stop 30
+ end subroutine
+ subroutine check_int_const_shape_scalar_mask_false_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_const_shape_scalar_mask(r, a, .true., .false.)
+ if (r /= 2) stop 37
+ end subroutine
+ subroutine check_int_const_shape_scalar_mask_true_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_const_shape_scalar_mask(r, a, .true., .true.)
+ if (r /= 5) stop 44
+ end subroutine
+ subroutine call_minloc_int_assumed_shape(r, a, b)
+ integer :: r, a(:)
+ logical, optional :: b
+ r = minloc(a, dim = 1, back = b)
+ end subroutine
+ subroutine check_int_assumed_shape_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_assumed_shape(r, a)
+ if (r /= 2) stop 51
+ end subroutine
+ subroutine check_int_assumed_shape_false_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_assumed_shape(r, a, .false.)
+ if (r /= 2) stop 58
+ end subroutine
+ subroutine check_int_assumed_shape_true_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_assumed_shape(r, a, .true.)
+ if (r /= 5) stop 65
+ end subroutine
+ subroutine call_minloc_int_assumed_shape_scalar_mask(r, a, m, b)
+ integer :: r, a(:)
+ logical :: m
+ logical, optional :: b
+ r = minloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_int_assumed_shape_scalar_mask_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_assumed_shape_scalar_mask(r, a, .true.)
+ if (r /= 2) stop 72
+ end subroutine
+ subroutine check_int_assumed_shape_scalar_mask_false_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_assumed_shape_scalar_mask(r, a, .true., .false.)
+ if (r /= 2) stop 79
+ end subroutine
+ subroutine check_int_assumed_shape_scalar_mask_true_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_assumed_shape_scalar_mask(r, a, .true., .true.)
+ if (r /= 5) stop 86
+ end subroutine
+ function id(a) result(r)
+ integer, dimension(:) :: a
+ integer, dimension(size(a, dim = 1)) :: r
+ r = a
+ end function
+ subroutine call_minloc_int_func(r, a, b)
+ integer :: r, a(:)
+ logical, optional :: b
+ r = minloc(id(a) + 1, dim = 1, back = b)
+ end subroutine
+ subroutine check_int_func_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_func(r, a)
+ if (r /= 2) stop 93
+ end subroutine
+ subroutine check_int_func_false_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_func(r, a, .false.)
+ if (r /= 2) stop 100
+ end subroutine
+ subroutine check_int_func_true_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_func(r, a, .true.)
+ if (r /= 5) stop 107
+ end subroutine
+ subroutine call_minloc_int_func_scalar_mask(r, a, m, b)
+ integer :: r, a(:)
+ logical :: m
+ logical, optional :: b
+ r = minloc(id(a) + 1, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_int_func_scalar_mask_absent_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_func_scalar_mask(r, a, .true.)
+ if (r /= 2) stop 114
+ end subroutine
+ subroutine check_int_func_scalar_mask_false_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_func_scalar_mask(r, a, .true., .false.)
+ if (r /= 2) stop 121
+ end subroutine
+ subroutine check_int_func_scalar_mask_true_back
+ integer :: r, a(10)
+ a = data
+ call call_minloc_int_func_scalar_mask(r, a, .true., .true.)
+ if (r /= 5) stop 128
+ end subroutine
+ subroutine call_minloc_int_const_shape_array_mask(r, a, m, b)
+ integer :: r, a(10)
+ logical :: m(10)
+ logical, optional :: b
+ r = minloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_int_const_shape_array_mask_absent_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_minloc_int_const_shape_array_mask(r, a, m)
+ if (r /= 1) stop 135
+ end subroutine
+ subroutine check_int_const_shape_array_mask_false_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_minloc_int_const_shape_array_mask(r, a, m, .false.)
+ if (r /= 1) stop 142
+ end subroutine
+ subroutine check_int_const_shape_array_mask_true_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_minloc_int_const_shape_array_mask(r, a, m, .true.)
+ if (r /= 9) stop 149
+ end subroutine
+ subroutine call_minloc_int_assumed_shape_array_mask(r, a, m, b)
+ integer :: r, a(:)
+ logical :: m(:)
+ logical, optional :: b
+ r = minloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_int_assumed_shape_array_mask_absent_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_minloc_int_assumed_shape_array_mask(r, a, m)
+ if (r /= 1) stop 156
+ end subroutine
+ subroutine check_int_assumed_shape_array_mask_false_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_minloc_int_assumed_shape_array_mask(r, a, m, .false.)
+ if (r /= 1) stop 163
+ end subroutine
+ subroutine check_int_assumed_shape_array_mask_true_back
+ integer :: r, a(10)
+ logical :: m(10)
+ a = data
+ m = mask
+ call call_minloc_int_assumed_shape_array_mask(r, a, m, .true.)
+ if (r /= 9) stop 170
+ end subroutine
+ subroutine call_minloc_real_const_shape(r, a, b)
+ integer :: r
+ real :: a(10)
+ logical, optional :: b
+ r = minloc(a, dim = 1, back = b)
+ end subroutine
+ subroutine check_real_const_shape_absent_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_const_shape(r, a)
+ if (r /= 2) stop 177
+ end subroutine
+ subroutine check_real_const_shape_false_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_const_shape(r, a, .false.)
+ if (r /= 2) stop 184
+ end subroutine
+ subroutine check_real_const_shape_true_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_const_shape(r, a, .true.)
+ if (r /= 5) stop 191
+ end subroutine
+ subroutine call_minloc_real_const_shape_scalar_mask(r, a, m, b)
+ integer :: r
+ real :: a(10)
+ logical :: m
+ logical, optional :: b
+ r = minloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_real_const_shape_scalar_mask_absent_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_const_shape_scalar_mask(r, a, .true.)
+ if (r /= 2) stop 198
+ end subroutine
+ subroutine check_real_const_shape_scalar_mask_false_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_const_shape_scalar_mask(r, a, .true., .false.)
+ if (r /= 2) stop 205
+ end subroutine
+ subroutine check_real_const_shape_scalar_mask_true_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_const_shape_scalar_mask(r, a, .true., .true.)
+ if (r /= 5) stop 212
+ end subroutine
+ subroutine call_minloc_real_assumed_shape(r, a, b)
+ integer :: r
+ real :: a(:)
+ logical, optional :: b
+ r = minloc(a, dim = 1, back = b)
+ end subroutine
+ subroutine check_real_assumed_shape_absent_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_assumed_shape(r, a)
+ if (r /= 2) stop 219
+ end subroutine
+ subroutine check_real_assumed_shape_false_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_assumed_shape(r, a, .false.)
+ if (r /= 2) stop 226
+ end subroutine
+ subroutine check_real_assumed_shape_true_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_assumed_shape(r, a, .true.)
+ if (r /= 5) stop 233
+ end subroutine
+ subroutine call_minloc_real_assumed_shape_scalar_mask(r, a, m, b)
+ integer :: r
+ real :: a(:)
+ logical :: m
+ logical, optional :: b
+ r = minloc(a, dim = 1, mask = m, back = b)
+ end subroutine
+ subroutine check_real_assumed_shape_scalar_mask_absent_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_assumed_shape_scalar_mask(r, a, .true.)
+ if (r /= 2) stop 240
+ end subroutine
+ subroutine check_real_assumed_shape_scalar_mask_false_back
+ integer :: r
+ real :: a(10)
+ a = (/ real :: data /)
+ call call_minloc_real_assumed_shape_scalar_mask(r, a, .true., .false.)
+ if (r /= 2) stop 247
+ end subroutine
+ subroutine check_real_assumed_shape_scalar_mask_true_back
+ integer :: r
+ real :: a(10)
+ a = data
+ a = (/ real :: data /)
+ call call_minloc_real_assumed_shape_scalar_mask(r, a, .true., .true.)
+ if (r /= 5) stop 254
+ end subroutine
+end program p
