Le 01/08/2024 à 21:02, Thomas Koenig a écrit :
Hi Mikael,
+ gcc_assert (backexpr->expr_type == EXPR_VARIABLE);
drop it, downgrade to checking, or is it worth?
Whether it is worth it, I don't know; it's protecting the access to
backexpr->symtree a few lines down, idependently of the implementation
of maybe_absent_optional_variable.
I expect the compiler to optimize it away, so I can surely make it a
checking-only assert.
I would also lean towards checking only.
OK with that change (or, if you really prefer, as submitted is also
fine).
Thanks for the patch! It's good to see so much progress...
Best regards
Thomas
Thanks to you and Bernhard.
This is what I'm going to push.
From 40122a405386a8b67c11bbaad523ffce5c1c7855 Mon Sep 17 00:00:00 2001
From: Mikael Morin <mik...@gcc.gnu.org>
Date: Fri, 2 Aug 2024 14:24:34 +0200
Subject: [PATCH] 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.
---
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(-)
create mode 100644 gcc/testsuite/gfortran.dg/maxloc_6.f90
create mode 100644 gcc/testsuite/gfortran.dg/minloc_7.f90
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 180d0d7a88c..150cb9ff963 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 00000000000..d5439b8dca0
--- /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 00000000000..7da77faaa01
--- /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
--
2.43.0
