This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
| Other format: | [Raw text] | |
On Thu, Jul 16, 2009 at 03:12:42PM +0200, Jakub Jelinek wrote:
> On Wed, Jul 15, 2009 at 06:13:16PM +0200, Jakub Jelinek wrote:
> The following patch fixes that and slightly improves even the two loops
> minloc/maxloc case, if we didn't terminate the first loop prematurely, we
> surely don't need to try to execute the second loop, on the other side if we
> executed the second loop, we know pos != 0, so can avoid the conditional
> after it.
Here is a new version. Changes since the July 16 version:
1) avoid using MAX_EXPR/MIN_EXPR for floating point vals unless -ffast-math,
MAX_EXPR/MIN_EXPR have unspecified behavior with NaNs or signed zeros
and e.g. minss NaN, Inf happily results in NaN on x86-64
2) slight optimization in gfc_conv_intrinsic_minmaxloc
(pos2 temporary isn't needed)
3) the library functions have been fixed/speeded up as well
Bootstrapped/regtested on x86_64-linux and i686-linux, ok for trunk?
The changes to the generated files are attached bzip2ed, as they are really
huge.
2009-07-22 Jakub Jelinek <jakub@redhat.com>
PR fortran/40643
PR fortran/31067
* trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc,
gfc_conv_intrinsic_minmaxval): Handle Infinities and NaNs properly,
optimize.
* trans-array.c (gfc_trans_scalarized_loop_end): No longer static.
* trans-array.h (gfc_trans_scalarized_loop_end): New prototype.
* libgfortran.h (GFC_REAL_4_INFINITY, GFC_REAL_8_INFINITY,
GFC_REAL_10_INFINITY, GFC_REAL_16_INFINITY, GFC_REAL_4_QUIET_NAN,
GFC_REAL_8_QUIET_NAN, GFC_REAL_10_QUIET_NAN, GFC_REAL_16_QUIET_NAN):
Define.
* m4/iparm.m4 (atype_inf, atype_nan): Define.
* m4/ifunction.m4: Formatting.
* m4/iforeach.m4: Likewise.
(START_FOREACH_FUNCTION): Initialize dest to all 1s, not all 0s.
(START_FOREACH_BLOCK, FINISH_FOREACH_FUNCTION,
FINISH_MASKED_FOREACH_FUNCTION): Run foreach block inside a loop
until count[0] == extent[0].
* m4/minval.m4: Formatting. Handle NaNs and infinities. Optimize.
* m4/maxval.m4: Likewise.
* m4/minloc0.m4: Likewise.
* m4/maxloc0.m4: Likewise.
* m4/minloc1.m4: Likewise.
* m4/maxloc1.m4: Likewise.
* generated/maxloc0_16_i16.c: Regenerated.
* generated/maxloc0_16_i1.c: Likewise.
* generated/maxloc0_16_i2.c: Likewise.
* generated/maxloc0_16_i4.c: Likewise.
* generated/maxloc0_16_i8.c: Likewise.
* generated/maxloc0_16_r10.c: Likewise.
* generated/maxloc0_16_r16.c: Likewise.
* generated/maxloc0_16_r4.c: Likewise.
* generated/maxloc0_16_r8.c: Likewise.
* generated/maxloc0_4_i16.c: Likewise.
* generated/maxloc0_4_i1.c: Likewise.
* generated/maxloc0_4_i2.c: Likewise.
* generated/maxloc0_4_i4.c: Likewise.
* generated/maxloc0_4_i8.c: Likewise.
* generated/maxloc0_4_r10.c: Likewise.
* generated/maxloc0_4_r16.c: Likewise.
* generated/maxloc0_4_r4.c: Likewise.
* generated/maxloc0_4_r8.c: Likewise.
* generated/maxloc0_8_i16.c: Likewise.
* generated/maxloc0_8_i1.c: Likewise.
* generated/maxloc0_8_i2.c: Likewise.
* generated/maxloc0_8_i4.c: Likewise.
* generated/maxloc0_8_i8.c: Likewise.
* generated/maxloc0_8_r10.c: Likewise.
* generated/maxloc0_8_r16.c: Likewise.
* generated/maxloc0_8_r4.c: Likewise.
* generated/maxloc0_8_r8.c: Likewise.
* generated/maxloc1_16_i16.c: Likewise.
* generated/maxloc1_16_i1.c: Likewise.
* generated/maxloc1_16_i2.c: Likewise.
* generated/maxloc1_16_i4.c: Likewise.
* generated/maxloc1_16_i8.c: Likewise.
* generated/maxloc1_16_r10.c: Likewise.
* generated/maxloc1_16_r16.c: Likewise.
* generated/maxloc1_16_r4.c: Likewise.
* generated/maxloc1_16_r8.c: Likewise.
* generated/maxloc1_4_i16.c: Likewise.
* generated/maxloc1_4_i1.c: Likewise.
* generated/maxloc1_4_i2.c: Likewise.
* generated/maxloc1_4_i4.c: Likewise.
* generated/maxloc1_4_i8.c: Likewise.
* generated/maxloc1_4_r10.c: Likewise.
* generated/maxloc1_4_r16.c: Likewise.
* generated/maxloc1_4_r4.c: Likewise.
* generated/maxloc1_4_r8.c: Likewise.
* generated/maxloc1_8_i16.c: Likewise.
* generated/maxloc1_8_i1.c: Likewise.
* generated/maxloc1_8_i2.c: Likewise.
* generated/maxloc1_8_i4.c: Likewise.
* generated/maxloc1_8_i8.c: Likewise.
* generated/maxloc1_8_r10.c: Likewise.
* generated/maxloc1_8_r16.c: Likewise.
* generated/maxloc1_8_r4.c: Likewise.
* generated/maxloc1_8_r8.c: Likewise.
* generated/maxval_i16.c: Likewise.
* generated/maxval_i1.c: Likewise.
* generated/maxval_i2.c: Likewise.
* generated/maxval_i4.c: Likewise.
* generated/maxval_i8.c: Likewise.
* generated/maxval_r10.c: Likewise.
* generated/maxval_r16.c: Likewise.
* generated/maxval_r4.c: Likewise.
* generated/maxval_r8.c: Likewise.
* generated/minloc0_16_i16.c: Likewise.
* generated/minloc0_16_i1.c: Likewise.
* generated/minloc0_16_i2.c: Likewise.
* generated/minloc0_16_i4.c: Likewise.
* generated/minloc0_16_i8.c: Likewise.
* generated/minloc0_16_r10.c: Likewise.
* generated/minloc0_16_r16.c: Likewise.
* generated/minloc0_16_r4.c: Likewise.
* generated/minloc0_16_r8.c: Likewise.
* generated/minloc0_4_i16.c: Likewise.
* generated/minloc0_4_i1.c: Likewise.
* generated/minloc0_4_i2.c: Likewise.
* generated/minloc0_4_i4.c: Likewise.
* generated/minloc0_4_i8.c: Likewise.
* generated/minloc0_4_r10.c: Likewise.
* generated/minloc0_4_r16.c: Likewise.
* generated/minloc0_4_r4.c: Likewise.
* generated/minloc0_4_r8.c: Likewise.
* generated/minloc0_8_i16.c: Likewise.
* generated/minloc0_8_i1.c: Likewise.
* generated/minloc0_8_i2.c: Likewise.
* generated/minloc0_8_i4.c: Likewise.
* generated/minloc0_8_i8.c: Likewise.
* generated/minloc0_8_r10.c: Likewise.
* generated/minloc0_8_r16.c: Likewise.
* generated/minloc0_8_r4.c: Likewise.
* generated/minloc0_8_r8.c: Likewise.
* generated/minloc1_16_i16.c: Likewise.
* generated/minloc1_16_i1.c: Likewise.
* generated/minloc1_16_i2.c: Likewise.
* generated/minloc1_16_i4.c: Likewise.
* generated/minloc1_16_i8.c: Likewise.
* generated/minloc1_16_r10.c: Likewise.
* generated/minloc1_16_r16.c: Likewise.
* generated/minloc1_16_r4.c: Likewise.
* generated/minloc1_16_r8.c: Likewise.
* generated/minloc1_4_i16.c: Likewise.
* generated/minloc1_4_i1.c: Likewise.
* generated/minloc1_4_i2.c: Likewise.
* generated/minloc1_4_i4.c: Likewise.
* generated/minloc1_4_i8.c: Likewise.
* generated/minloc1_4_r10.c: Likewise.
* generated/minloc1_4_r16.c: Likewise.
* generated/minloc1_4_r4.c: Likewise.
* generated/minloc1_4_r8.c: Likewise.
* generated/minloc1_8_i16.c: Likewise.
* generated/minloc1_8_i1.c: Likewise.
* generated/minloc1_8_i2.c: Likewise.
* generated/minloc1_8_i4.c: Likewise.
* generated/minloc1_8_i8.c: Likewise.
* generated/minloc1_8_r10.c: Likewise.
* generated/minloc1_8_r16.c: Likewise.
* generated/minloc1_8_r4.c: Likewise.
* generated/minloc1_8_r8.c: Likewise.
* generated/minval_i16.c: Likewise.
* generated/minval_i1.c: Likewise.
* generated/minval_i2.c: Likewise.
* generated/minval_i4.c: Likewise.
* generated/minval_i8.c: Likewise.
* generated/minval_r10.c: Likewise.
* generated/minval_r16.c: Likewise.
* generated/minval_r4.c: Likewise.
* generated/minval_r8.c: Likewise.
* generated/product_c10.c: Likewise.
* generated/product_c16.c: Likewise.
* generated/product_c4.c: Likewise.
* generated/product_c8.c: Likewise.
* generated/product_i16.c: Likewise.
* generated/product_i1.c: Likewise.
* generated/product_i2.c: Likewise.
* generated/product_i4.c: Likewise.
* generated/product_i8.c: Likewise.
* generated/product_r10.c: Likewise.
* generated/product_r16.c: Likewise.
* generated/product_r4.c: Likewise.
* generated/product_r8.c: Likewise.
* generated/sum_c10.c: Likewise.
* generated/sum_c16.c: Likewise.
* generated/sum_c4.c: Likewise.
* generated/sum_c8.c: Likewise.
* generated/sum_i16.c: Likewise.
* generated/sum_i1.c: Likewise.
* generated/sum_i2.c: Likewise.
* generated/sum_i4.c: Likewise.
* generated/sum_i8.c: Likewise.
* generated/sum_r10.c: Likewise.
* generated/sum_r16.c: Likewise.
* generated/sum_r4.c: Likewise.
* generated/sum_r8.c: Likewise.
* gfortran.dg/maxlocval_2.f90: New test.
* gfortran.dg/maxlocval_3.f90: New test.
* gfortran.dg/maxlocval_4.f90: New test.
* gfortran.dg/minlocval_1.f90: New test.
* gfortran.dg/minlocval_2.f90: New test.
* gfortran.dg/minlocval_3.f90: New test.
* gfortran.dg/minlocval_4.f90: New test.
--- gcc/fortran/trans-intrinsic.c.jj 2009-07-20 20:41:43.000000000 +0200
+++ gcc/fortran/trans-intrinsic.c 2009-07-22 19:12:40.000000000 +0200
@@ -2146,6 +2146,72 @@ gfc_conv_intrinsic_dot_product (gfc_se *
}
+/* Emit code for minloc or maxloc intrinsic. There are many different cases
+ we need to handle. For performance reasons we sometimes create two
+ loops instead of one, where the second one is much simpler.
+ Examples for minloc intrinsic:
+ 1) Result is an array, a call is generated
+ 2) Array mask is used and NaNs need to be supported:
+ limit = Infinity;
+ pos = 0;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) {
+ if (pos == 0) pos = S + (1 - from);
+ if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+ }
+ S++;
+ }
+ goto lab2;
+ lab1:;
+ while (S <= to) {
+ if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ lab2:;
+ 3) NaNs need to be supported, but it is known at compile time or cheaply
+ at runtime whether array is nonempty or not:
+ limit = Infinity;
+ pos = 0;
+ S = from;
+ while (S <= to) {
+ if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+ S++;
+ }
+ if (from <= to) pos = 1;
+ goto lab2;
+ lab1:;
+ while (S <= to) {
+ if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ lab2:;
+ 4) NaNs aren't supported, array mask is used:
+ limit = infinities_supported ? Infinity : huge (limit);
+ pos = 0;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+ S++;
+ }
+ goto lab2;
+ lab1:;
+ while (S <= to) {
+ if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ lab2:;
+ 5) Same without array mask:
+ limit = infinities_supported ? Infinity : huge (limit);
+ pos = (from <= to) ? 1 : 0;
+ S = from;
+ while (S <= to) {
+ if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ For 3) and 5), if mask is scalar, this all goes into a conditional,
+ setting pos = 0; in the else branch. */
+
static void
gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
@@ -2156,9 +2222,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
tree limit;
tree type;
tree tmp;
+ tree cond;
tree elsetmp;
tree ifbody;
tree offset;
+ tree nonempty;
+ tree lab1, lab2;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
gfc_ss *arrayss;
@@ -2190,21 +2259,39 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
+ nonempty = NULL;
if (maskexpr && maskexpr->rank != 0)
{
maskss = gfc_walk_expr (maskexpr);
gcc_assert (maskss != gfc_ss_terminator);
}
else
- maskss = NULL;
+ {
+ mpz_t asize;
+ if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
+ {
+ nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
+ mpz_clear (asize);
+ nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
+ gfc_index_zero_node);
+ }
+ maskss = NULL;
+ }
limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
switch (arrayexpr->ts.type)
{
case BT_REAL:
- tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
- arrayexpr->ts.kind, 0);
+ if (HONOR_INFINITIES (DECL_MODE (limit)))
+ {
+ REAL_VALUE_TYPE real;
+ real_inf (&real);
+ tmp = build_real (TREE_TYPE (limit), real);
+ }
+ else
+ tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
+ arrayexpr->ts.kind, 0);
break;
case BT_INTEGER:
@@ -2239,11 +2326,30 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
gfc_conv_loop_setup (&loop, &expr->where);
gcc_assert (loop.dimen == 1);
+ if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
+ nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
+ loop.to[0]);
+ lab1 = NULL;
+ lab2 = NULL;
/* Initialize the position to zero, following Fortran 2003. We are free
to do this because Fortran 95 allows the result of an entirely false
- mask to be processor dependent. */
- gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
+ mask to be processor dependent. If we know at compile time the array
+ is non-empty and no MASK is used, we can initialize to 1 to simplify
+ the inner loop. */
+ if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
+ gfc_add_modify (&loop.pre, pos,
+ fold_build3 (COND_EXPR, gfc_array_index_type,
+ nonempty, gfc_index_one_node,
+ gfc_index_zero_node));
+ else
+ {
+ gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
+ lab1 = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (lab1) = 1;
+ lab2 = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (lab2) = 1;
+ }
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
@@ -2285,27 +2391,47 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
gfc_index_one_node, loop.from[0]);
else
tmp = gfc_index_one_node;
-
+
gfc_add_modify (&block, offset, tmp);
+ if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
+ {
+ stmtblock_t ifblock2;
+ tree ifbody2;
+
+ gfc_start_block (&ifblock2);
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify (&ifblock2, pos, tmp);
+ ifbody2 = gfc_finish_block (&ifblock2);
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, pos,
+ gfc_index_zero_node);
+ tmp = build3_v (COND_EXPR, cond, ifbody2,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
loop.loopvar[0], offset);
gfc_add_modify (&ifblock, pos, tmp);
+ if (lab1)
+ gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
+
ifbody = gfc_finish_block (&ifblock);
- /* If it is a more extreme value or pos is still zero and the value
- equal to the limit. */
- tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- fold_build2 (EQ_EXPR, boolean_type_node,
- pos, gfc_index_zero_node),
- fold_build2 (EQ_EXPR, boolean_type_node,
- arrayse.expr, limit));
- tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
- fold_build2 (op, boolean_type_node,
- arrayse.expr, limit), tmp);
- tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&block, tmp);
+ if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
+ {
+ if (lab1)
+ cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
+ boolean_type_node, arrayse.expr, limit);
+ else
+ cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+
+ ifbody = build3_v (COND_EXPR, cond, ifbody,
+ build_empty_stmt (input_location));
+ }
+ gfc_add_expr_to_block (&block, ifbody);
if (maskss)
{
@@ -2319,8 +2445,95 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&body, tmp);
+ if (lab1)
+ {
+ gfc_trans_scalarized_loop_end (&loop, 0, &body);
+
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ if (nonempty != NULL)
+ {
+ ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
+ tmp = build3_v (COND_EXPR, nonempty, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&loop.code[0], tmp);
+ }
+ }
+
+ gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
+ gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
+ gfc_start_block (&body);
+
+ /* If we have a mask, only check this element if the mask is set. */
+ if (maskss)
+ {
+ gfc_init_se (&maskse, NULL);
+ gfc_copy_loopinfo_to_se (&maskse, &loop);
+ maskse.ss = maskss;
+ gfc_conv_expr_val (&maskse, maskexpr);
+ gfc_add_block_to_block (&body, &maskse.pre);
+
+ gfc_start_block (&block);
+ }
+ else
+ 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_conv_expr_val (&arrayse, arrayexpr);
+ gfc_add_block_to_block (&block, &arrayse.pre);
+
+ /* We do the following if this is a more extreme value. */
+ gfc_start_block (&ifblock);
+
+ /* Assign the value to the limit... */
+ gfc_add_modify (&ifblock, limit, arrayse.expr);
+
+ /* Remember where we are. An offset must be added to the loop
+ counter to obtain the required position. */
+ if (loop.from[0])
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[0]);
+ else
+ tmp = gfc_index_one_node;
+
+ gfc_add_modify (&block, offset, tmp);
+
+ tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify (&ifblock, pos, tmp);
+
+ ifbody = gfc_finish_block (&ifblock);
+
+ cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+
+ tmp = build3_v (COND_EXPR, cond, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (maskss)
+ {
+ /* We enclose the above in if (mask) {...}. */
+ tmp = gfc_finish_block (&block);
+
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
+ }
+ else
+ tmp = gfc_finish_block (&block);
+ gfc_add_expr_to_block (&body, tmp);
+ /* Avoid initializing loopvar[0] again, it should be left where
+ it finished by the first loop. */
+ loop.from[0] = loop.loopvar[0];
+ }
+
gfc_trans_scalarizing_loops (&loop, &body);
+ if (lab2)
+ gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
+
/* For a scalar mask, enclose the loop in an if statement. */
if (maskexpr && maskss == NULL)
{
@@ -2352,6 +2565,99 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
se->expr = convert (type, pos);
}
+/* Emit code for minval or maxval intrinsic. There are many different cases
+ we need to handle. For performance reasons we sometimes create two
+ loops instead of one, where the second one is much simpler.
+ Examples for minval intrinsic:
+ 1) Result is an array, a call is generated
+ 2) Array mask is used and NaNs need to be supported, rank 1:
+ limit = Infinity;
+ nonempty = false;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
+ S++;
+ }
+ limit = nonempty ? NaN : huge (limit);
+ lab:
+ while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
+ 3) NaNs need to be supported, but it is known at compile time or cheaply
+ at runtime whether array is nonempty or not, rank 1:
+ limit = Infinity;
+ S = from;
+ while (S <= to) { if (a[S] <= limit) goto lab; S++; }
+ limit = (from <= to) ? NaN : huge (limit);
+ lab:
+ while (S <= to) { limit = min (a[S], limit); S++; }
+ 4) Array mask is used and NaNs need to be supported, rank > 1:
+ limit = Infinity;
+ nonempty = false;
+ fast = false;
+ S1 = from1;
+ while (S1 <= to1) {
+ S2 = from2;
+ while (S2 <= to2) {
+ if (mask[S1][S2]) {
+ if (fast) limit = min (a[S1][S2], limit);
+ else {
+ nonempty = true;
+ if (a[S1][S2] <= limit) {
+ limit = a[S1][S2];
+ fast = true;
+ }
+ }
+ }
+ S2++;
+ }
+ S1++;
+ }
+ if (!fast)
+ limit = nonempty ? NaN : huge (limit);
+ 5) NaNs need to be supported, but it is known at compile time or cheaply
+ at runtime whether array is nonempty or not, rank > 1:
+ limit = Infinity;
+ fast = false;
+ S1 = from1;
+ while (S1 <= to1) {
+ S2 = from2;
+ while (S2 <= to2) {
+ if (fast) limit = min (a[S1][S2], limit);
+ else {
+ if (a[S1][S2] <= limit) {
+ limit = a[S1][S2];
+ fast = true;
+ }
+ }
+ S2++;
+ }
+ S1++;
+ }
+ if (!fast)
+ limit = (nonempty_array) ? NaN : huge (limit);
+ 6) NaNs aren't supported, but infinities are. Array mask is used:
+ limit = Infinity;
+ nonempty = false;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
+ S++;
+ }
+ limit = nonempty ? limit : huge (limit);
+ 7) Same without array mask:
+ limit = Infinity;
+ S = from;
+ while (S <= to) { limit = min (a[S], limit); S++; }
+ limit = (from <= to) ? limit : huge (limit);
+ 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
+ limit = huge (limit);
+ S = from;
+ while (S <= to) { limit = min (a[S], limit); S++); }
+ (or
+ while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
+ with array mask instead).
+ For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
+ setting limit = huge (limit); in the else branch. */
+
static void
gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
@@ -2359,8 +2665,13 @@ gfc_conv_intrinsic_minmaxval (gfc_se * s
tree type;
tree tmp;
tree ifbody;
+ tree nonempty;
+ tree nonempty_var;
+ tree lab;
+ tree fast;
+ tree huge_cst = NULL, nan_cst = NULL;
stmtblock_t body;
- stmtblock_t block;
+ stmtblock_t block, block2;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
gfc_ss *arrayss;
@@ -2384,7 +2695,22 @@ gfc_conv_intrinsic_minmaxval (gfc_se * s
switch (expr->ts.type)
{
case BT_REAL:
- tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind, 0);
+ huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
+ expr->ts.kind, 0);
+ if (HONOR_INFINITIES (DECL_MODE (limit)))
+ {
+ REAL_VALUE_TYPE real;
+ real_inf (&real);
+ tmp = build_real (type, real);
+ }
+ else
+ tmp = huge_cst;
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ REAL_VALUE_TYPE real;
+ real_nan (&real, "", 1, DECL_MODE (limit));
+ nan_cst = build_real (type, real);
+ }
break;
case BT_INTEGER:
@@ -2400,7 +2726,11 @@ gfc_conv_intrinsic_minmaxval (gfc_se * s
-HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
possible value is HUGE in both cases. */
if (op == GT_EXPR)
- tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+ {
+ tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+ if (huge_cst)
+ huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
+ }
if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
@@ -2417,13 +2747,24 @@ gfc_conv_intrinsic_minmaxval (gfc_se * s
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
+ nonempty = NULL;
if (maskexpr && maskexpr->rank != 0)
{
maskss = gfc_walk_expr (maskexpr);
gcc_assert (maskss != gfc_ss_terminator);
}
else
- maskss = NULL;
+ {
+ mpz_t asize;
+ if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
+ {
+ nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
+ mpz_clear (asize);
+ nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
+ gfc_index_zero_node);
+ }
+ maskss = NULL;
+ }
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
@@ -2435,6 +2776,35 @@ gfc_conv_intrinsic_minmaxval (gfc_se * s
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop, &expr->where);
+ if (nonempty == NULL && maskss == NULL
+ && loop.dimen == 1 && loop.from[0] && loop.to[0])
+ nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
+ loop.to[0]);
+ nonempty_var = NULL;
+ if (nonempty == NULL
+ && (HONOR_INFINITIES (DECL_MODE (limit))
+ || HONOR_NANS (DECL_MODE (limit))))
+ {
+ nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
+ gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
+ nonempty = nonempty_var;
+ }
+ lab = NULL;
+ fast = NULL;
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ if (loop.dimen == 1)
+ {
+ lab = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (lab) = 1;
+ }
+ else
+ {
+ fast = gfc_create_var (boolean_type_node, "fast");
+ gfc_add_modify (&se->pre, fast, boolean_false_node);
+ }
+ }
+
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_mark_ss_chain_used (maskss, 1);
@@ -2462,13 +2832,76 @@ gfc_conv_intrinsic_minmaxval (gfc_se * s
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
- /* Assign the value to the limit... */
- ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ gfc_init_block (&block2);
+
+ if (nonempty_var)
+ gfc_add_modify (&block2, nonempty_var, boolean_true_node);
+
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
+ boolean_type_node, arrayse.expr, limit);
+ if (lab)
+ ifbody = build1_v (GOTO_EXPR, lab);
+ else
+ {
+ stmtblock_t ifblock;
+
+ gfc_init_block (&ifblock);
+ gfc_add_modify (&ifblock, limit, arrayse.expr);
+ gfc_add_modify (&ifblock, fast, boolean_true_node);
+ ifbody = gfc_finish_block (&ifblock);
+ }
+ tmp = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
+ }
+ else
+ {
+ /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+ signed zeros. */
+ if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ tmp = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
+ }
+ else
+ {
+ tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+ type, arrayse.expr, limit);
+ gfc_add_modify (&block2, limit, tmp);
+ }
+ }
+
+ if (fast)
+ {
+ tree elsebody = gfc_finish_block (&block2);
+
+ /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+ signed zeros. */
+ if (HONOR_NANS (DECL_MODE (limit))
+ || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ ifbody = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ }
+ else
+ {
+ tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+ type, arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, tmp);
+ }
+ tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ gfc_add_block_to_block (&block, &block2);
- /* If it is a more extreme value. */
- tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
- tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt (input_location));
- gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &arrayse.post);
tmp = gfc_finish_block (&block);
@@ -2478,11 +2911,88 @@ gfc_conv_intrinsic_minmaxval (gfc_se * s
build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
+ if (lab)
+ {
+ gfc_trans_scalarized_loop_end (&loop, 0, &body);
+
+ tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
+ gfc_add_modify (&loop.code[0], limit, tmp);
+ gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
+
+ gfc_start_block (&body);
+
+ /* If we have a mask, only add this element if the mask is set. */
+ if (maskss)
+ {
+ gfc_init_se (&maskse, NULL);
+ gfc_copy_loopinfo_to_se (&maskse, &loop);
+ maskse.ss = maskss;
+ gfc_conv_expr_val (&maskse, maskexpr);
+ gfc_add_block_to_block (&body, &maskse.pre);
+
+ gfc_start_block (&block);
+ }
+ else
+ 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_conv_expr_val (&arrayse, arrayexpr);
+ gfc_add_block_to_block (&block, &arrayse.pre);
+
+ /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+ signed zeros. */
+ if (HONOR_NANS (DECL_MODE (limit))
+ || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ tmp = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ {
+ tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+ type, arrayse.expr, limit);
+ gfc_add_modify (&block, limit, tmp);
+ }
+
+ gfc_add_block_to_block (&block, &arrayse.post);
+
+ tmp = gfc_finish_block (&block);
+ if (maskss)
+ /* We enclose the above in if (mask) {...}. */
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&body, tmp);
+ /* Avoid initializing loopvar[0] again, it should be left where
+ it finished by the first loop. */
+ loop.from[0] = loop.loopvar[0];
+ }
gfc_trans_scalarizing_loops (&loop, &body);
+ if (fast)
+ {
+ tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
+ ifbody = build2_v (MODIFY_EXPR, limit, tmp);
+ tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
+ ifbody);
+ gfc_add_expr_to_block (&loop.pre, tmp);
+ }
+ else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
+ {
+ tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst);
+ gfc_add_modify (&loop.pre, limit, tmp);
+ }
+
/* For a scalar mask, enclose the loop in an if statement. */
if (maskexpr && maskss == NULL)
{
+ tree else_stmt;
+
gfc_init_se (&maskse, NULL);
gfc_conv_expr_val (&maskse, maskexpr);
gfc_init_block (&block);
@@ -2490,8 +3000,11 @@ gfc_conv_intrinsic_minmaxval (gfc_se * s
gfc_add_block_to_block (&block, &loop.post);
tmp = gfc_finish_block (&block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp,
- build_empty_stmt (input_location));
+ if (HONOR_INFINITIES (DECL_MODE (limit)))
+ else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
+ else
+ else_stmt = build_empty_stmt (input_location);
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&se->pre, &block);
}
--- gcc/fortran/trans-array.c.jj 2009-07-20 20:41:43.000000000 +0200
+++ gcc/fortran/trans-array.c 2009-07-22 17:45:44.000000000 +0200
@@ -2755,7 +2755,7 @@ gfc_start_scalarized_body (gfc_loopinfo
/* Generates the actual loop code for a scalarization loop. */
-static void
+void
gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n,
stmtblock_t * pbody)
{
@@ -2822,7 +2822,8 @@ gfc_trans_scalarized_loop_end (gfc_loopi
loopbody = gfc_finish_block (pbody);
/* Initialize the loopvar. */
- gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
+ if (loop->loopvar[n] != loop->from[n])
+ gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]);
exit_label = gfc_build_label_decl (NULL_TREE);
--- gcc/fortran/trans-array.h.jj 2009-07-20 20:41:41.000000000 +0200
+++ gcc/fortran/trans-array.h 2009-07-22 17:45:44.000000000 +0200
@@ -1,5 +1,5 @@
/* Header for array handling functions
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
Free Software Foundation, Inc.
Contributed by Paul Brook
@@ -84,6 +84,8 @@ void gfc_copy_loopinfo_to_se (gfc_se *,
/* Marks the start of a scalarized expression, and declares loop variables. */
void gfc_start_scalarized_body (gfc_loopinfo *, stmtblock_t *);
+/* Generates one actual loop for a scalarized expression. */
+void gfc_trans_scalarized_loop_end (gfc_loopinfo *, int, stmtblock_t *);
/* Generates the actual loops for a scalarized expression. */
void gfc_trans_scalarizing_loops (gfc_loopinfo *, stmtblock_t *);
/* Mark the end of the main loop body and the start of the copying loop. */
--- libgfortran/libgfortran.h.jj 2009-07-20 20:42:14.000000000 +0200
+++ libgfortran/libgfortran.h 2009-07-21 11:18:17.000000000 +0200
@@ -294,6 +294,36 @@ internal_proto(big_endian);
(GFC_INTEGER_16)((((GFC_UINTEGER_16)1) << 127) - 1)
#endif
+/* M{IN,AX}{LOC,VAL} need also infinities and NaNs if supported. */
+
+#ifdef __FLT_HAS_INFINITY__
+# define GFC_REAL_4_INFINITY __builtin_inff ()
+#endif
+#ifdef __DBL_HAS_INFINITY__
+# define GFC_REAL_8_INFINITY __builtin_inf ()
+#endif
+#ifdef __LDBL_HAS_INFINITY__
+# ifdef HAVE_GFC_REAL_10
+# define GFC_REAL_10_INFINITY __builtin_infl ()
+# endif
+# ifdef HAVE_GFC_REAL_16
+# define GFC_REAL_16_INFINITY __builtin_infl ()
+# endif
+#endif
+#ifdef __FLT_HAS_QUIET_NAN__
+# define GFC_REAL_4_QUIET_NAN __builtin_nanf ("")
+#endif
+#ifdef __DBL_HAS_QUIET_NAN__
+# define GFC_REAL_8_QUIET_NAN __builtin_nan ("")
+#endif
+#ifdef __LDBL_HAS_QUIET_NAN__
+# ifdef HAVE_GFC_REAL_10
+# define GFC_REAL_10_QUIET_NAN __builtin_nanl ("")
+# endif
+# ifdef HAVE_GFC_REAL_16
+# define GFC_REAL_16_QUIET_NAN __builtin_nanl ("")
+# endif
+#endif
typedef struct descriptor_dimension
{
--- libgfortran/m4/iparm.m4.jj 2009-07-20 20:41:42.000000000 +0200
+++ libgfortran/m4/iparm.m4 2009-07-21 11:18:17.000000000 +0200
@@ -29,6 +29,8 @@ define(rtype_qual,`_'rtype_kind)dnl
')dnl
define(atype_max, atype_name`_HUGE')dnl
define(atype_min,ifelse(regexp(file, `_\(.\)[0-9]*\.c$', `\1'),`i',`(-'atype_max`-1)',`-'atype_max))dnl
+define(atype_inf, atype_name`_INFINITY')dnl
+define(atype_nan, atype_name`_QUIET_NAN')dnl
define(name, regexp(regexp(file, `[^/]*$', `\&'), `^\([^_]*\)_', `\1'))dnl
define(`upcase', `translit(`$*', `a-z', `A-Z')')dnl
define(`u_name',`regexp(upcase(name),`\([A-Z]*\)',`\1')')dnl
--- libgfortran/m4/ifunction.m4.jj 2009-07-20 20:42:13.000000000 +0200
+++ libgfortran/m4/ifunction.m4 2009-07-22 10:41:53.000000000 +0200
@@ -72,15 +72,15 @@ name`'rtype_qual`_'atype_code (rtype * c
size_t alloc_size, str;
for (n = 0; n < rank; n++)
- {
- if (n == 0)
+ {
+ if (n == 0)
str = 1;
- else
- str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
- }
+ }
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
@@ -116,7 +116,7 @@ name`'rtype_qual`_'atype_code (rtype * c
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
if (extent[n] <= 0)
- len = 0;
+ len = 0;
}
base = array->data;
@@ -131,7 +131,7 @@ name`'rtype_qual`_'atype_code (rtype * c
{
')dnl
define(START_ARRAY_BLOCK,
-` if (len <= 0)
+` if (len <= 0)
*dest = '$1`;
else
{
@@ -139,7 +139,7 @@ define(START_ARRAY_BLOCK,
{
')dnl
define(FINISH_ARRAY_FUNCTION,
- ` }
+` }
*dest = result;
}
}
@@ -149,28 +149,28 @@ define(FINISH_ARRAY_FUNCTION,
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
- {
- /* When we get to the end of a dimension, reset it and increment
- the next dimension. */
- count[n] = 0;
- /* We could precalculate these products, but this is a less
- frequently used path so probably not worth it. */
- base -= sstride[n] * extent[n];
- dest -= dstride[n] * extent[n];
- n++;
- if (n == rank)
- {
- /* Break out of the look. */
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
continue_loop = 0;
break;
- }
- else
- {
- count[n]++;
- base += sstride[n];
- dest += dstride[n];
- }
- }
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ dest += dstride[n];
+ }
+ }
}
}')dnl
define(START_MASKED_ARRAY_FUNCTION,
@@ -250,15 +250,15 @@ void
size_t alloc_size, str;
for (n = 0; n < rank; n++)
- {
- if (n == 0)
- str = 1;
- else
- str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
- }
+ }
alloc_size = sizeof (rtype_name) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
* extent[rank-1];
@@ -295,7 +295,7 @@ void
count[n] = 0;
dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
if (extent[n] <= 0)
- return;
+ return;
}
dest = retarray->data;
@@ -311,7 +311,7 @@ void
{
')dnl
define(START_MASKED_ARRAY_BLOCK,
-` if (len <= 0)
+` if (len <= 0)
*dest = '$1`;
else
{
@@ -319,7 +319,7 @@ define(START_MASKED_ARRAY_BLOCK,
{
')dnl
define(FINISH_MASKED_ARRAY_FUNCTION,
-` }
+` }
*dest = result;
}
}
@@ -330,30 +330,30 @@ define(FINISH_MASKED_ARRAY_FUNCTION,
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
- {
- /* When we get to the end of a dimension, reset it and increment
- the next dimension. */
- count[n] = 0;
- /* We could precalculate these products, but this is a less
- frequently used path so probably not worth it. */
- base -= sstride[n] * extent[n];
- mbase -= mstride[n] * extent[n];
- dest -= dstride[n] * extent[n];
- n++;
- if (n == rank)
- {
- /* Break out of the look. */
- base = NULL;
- break;
- }
- else
- {
- count[n]++;
- base += sstride[n];
- mbase += mstride[n];
- dest += dstride[n];
- }
- }
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the look. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ dest += dstride[n];
+ }
+ }
}
}')dnl
define(SCALAR_ARRAY_FUNCTION,
@@ -401,10 +401,10 @@ void
{
sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
extent[n] =
- GFC_DESCRIPTOR_EXTENT(array,n + 1);
+ GFC_DESCRIPTOR_EXTENT(array,n + 1);
if (extent[n] <= 0)
- extent[n] = 0;
+ extent[n] = 0;
}
if (retarray->data == NULL)
@@ -412,15 +412,15 @@ void
size_t alloc_size, str;
for (n = 0; n < rank; n++)
- {
- if (n == 0)
- str = 1;
- else
- str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
+ {
+ if (n == 0)
+ str = 1;
+ else
+ str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
- }
+ }
retarray->offset = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
@@ -476,21 +476,21 @@ void
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
- {
+ {
/* When we get to the end of a dimension, reset it and increment
- the next dimension. */
- count[n] = 0;
- /* We could precalculate these products, but this is a less
- frequently used path so probably not worth it. */
- dest -= dstride[n] * extent[n];
- n++;
- if (n == rank)
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ dest -= dstride[n] * extent[n];
+ n++;
+ if (n == rank)
return;
- else
- {
- count[n]++;
- dest += dstride[n];
- }
+ else
+ {
+ count[n]++;
+ dest += dstride[n];
+ }
}
}
}')dnl
--- libgfortran/m4/iforeach.m4.jj 2009-07-20 20:42:13.000000000 +0200
+++ libgfortran/m4/iforeach.m4 2009-07-22 17:19:07.000000000 +0200
@@ -35,8 +35,8 @@ name`'rtype_qual`_'atype_code (rtype * c
else
{
if (unlikely (compile_options.bounds_check))
- bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
- "u_name");
+ bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
+ "u_name");
}
dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
@@ -59,43 +59,45 @@ name`'rtype_qual`_'atype_code (rtype * c
/* Initialize the return value. */
for (n = 0; n < rank; n++)
- dest[n * dstride] = 0;
+ dest[n * dstride] = 1;
{
')dnl
define(START_FOREACH_BLOCK,
` while (base)
{
- {
- /* Implementation start. */
+ do
+ {
+ /* Implementation start. */
')dnl
define(FINISH_FOREACH_FUNCTION,
-` /* Implementation end. */
- }
- /* Advance to the next element. */
- count[0]++;
- base += sstride[0];
+` /* Implementation end. */
+ /* Advance to the next element. */
+ base += sstride[0];
+ }
+ while (++count[0] != extent[0]);
n = 0;
- while (count[n] == extent[n])
- {
- /* When we get to the end of a dimension, reset it and increment
- the next dimension. */
- count[n] = 0;
- /* We could precalculate these products, but this is a less
- frequently used path so probably not worth it. */
- base -= sstride[n] * extent[n];
- n++;
- if (n == rank)
- {
- /* Break out of the loop. */
- base = NULL;
- break;
- }
- else
- {
- count[n]++;
- base += sstride[n];
- }
- }
+ do
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the loop. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ }
+ }
+ while (count[n] == extent[n]);
}
}
}')dnl
@@ -184,36 +186,37 @@ void
')dnl
define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
define(FINISH_MASKED_FOREACH_FUNCTION,
-` /* Implementation end. */
- }
- /* Advance to the next element. */
- count[0]++;
- base += sstride[0];
- mbase += mstride[0];
+` /* Implementation end. */
+ /* Advance to the next element. */
+ base += sstride[0];
+ mbase += mstride[0];
+ }
+ while (++count[0] != extent[0]);
n = 0;
- while (count[n] == extent[n])
- {
- /* When we get to the end of a dimension, reset it and increment
- the next dimension. */
- count[n] = 0;
- /* We could precalculate these products, but this is a less
- frequently used path so probably not worth it. */
- base -= sstride[n] * extent[n];
- mbase -= mstride[n] * extent[n];
- n++;
- if (n == rank)
- {
- /* Break out of the loop. */
- base = NULL;
- break;
- }
- else
- {
- count[n]++;
- base += sstride[n];
- mbase += mstride[n];
- }
- }
+ do
+ {
+ /* When we get to the end of a dimension, reset it and increment
+ the next dimension. */
+ count[n] = 0;
+ /* We could precalculate these products, but this is a less
+ frequently used path so probably not worth it. */
+ base -= sstride[n] * extent[n];
+ mbase -= mstride[n] * extent[n];
+ n++;
+ if (n == rank)
+ {
+ /* Break out of the loop. */
+ base = NULL;
+ break;
+ }
+ else
+ {
+ count[n]++;
+ base += sstride[n];
+ mbase += mstride[n];
+ }
+ }
+ while (count[n] == extent[n]);
}
}
}')dnl
--- libgfortran/m4/maxloc1.m4.jj 2009-04-14 16:35:13.000000000 +0200
+++ libgfortran/m4/maxloc1.m4 2009-07-22 13:48:31.000000000 +0200
@@ -34,24 +34,67 @@ include(ifunction.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
ARRAY_FUNCTION(0,
-` atype_name maxval;
- maxval = atype_min;
- result = 0;',
-` if (*src > maxval || !result)
- {
- maxval = *src;
- result = (rtype_name)n + 1;
- }')
+` atype_name maxval;
+#if defined ('atype_inf`)
+ maxval = -atype_inf;
+#else
+ maxval = atype_min;
+#endif
+ result = 1;',
+`#if defined ('atype_nan`)
+ if (*src >= maxval)
+ {
+ maxval = *src;
+ result = (rtype_name)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta)
+ {
+#endif
+ if (*src > maxval)
+ {
+ maxval = *src;
+ result = (rtype_name)n + 1;
+ }')
MASKED_ARRAY_FUNCTION(0,
-` atype_name maxval;
- maxval = atype_min;
- result = 0;',
-` if (*msrc && (*src > maxval || !result))
- {
- maxval = *src;
- result = (rtype_name)n + 1;
- }')
+` atype_name maxval;
+#if defined ('atype_inf`)
+ maxval = -atype_inf;
+#else
+ maxval = atype_min;
+#endif
+#if defined ('atype_nan`)
+ rtype_name result2 = 0;
+#endif
+ result = 0;',
+` if (*msrc)
+ {
+#if defined ('atype_nan`)
+ if (!result2)
+ result2 = (rtype_name)n + 1;
+ if (*src >= maxval)
+#endif
+ {
+ maxval = *src;
+ result = (rtype_name)n + 1;
+ break;
+ }
+ }
+ }
+#if defined ('atype_nan`)
+ if (__builtin_expect (n >= len, 0))
+ result = result2;
+ else
+#endif
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && *src > maxval)
+ {
+ maxval = *src;
+ result = (rtype_name)n + 1;
+ }')
SCALAR_ARRAY_FUNCTION(0)
--- libgfortran/m4/minval.m4.jj 2009-07-20 20:41:42.000000000 +0200
+++ libgfortran/m4/minval.m4 2009-07-21 12:22:01.000000000 +0200
@@ -33,14 +33,55 @@ include(ifunction.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
ARRAY_FUNCTION(atype_max,
-` result = atype_max;',
-` if (*src < result)
- result = *src;')
+`#if defined ('atype_inf`)
+ result = atype_inf;
+#else
+ result = atype_max;
+#endif',
+`#if defined ('atype_nan`)
+ if (*src <= result)
+ break;
+ }
+ if (__builtin_expect (n >= len, 0))
+ result = atype_nan;
+ else for (; n < len; n++, src += delta)
+ {
+#endif
+ if (*src < result)
+ result = *src;')
MASKED_ARRAY_FUNCTION(atype_max,
-` result = atype_max;',
-` if (*msrc && *src < result)
- result = *src;')
+`#if defined ('atype_inf`)
+ result = atype_inf;
+#else
+ result = atype_max;
+#endif
+#if defined ('atype_nan`)
+ int non_empty_p = 0;
+#endif',
+`#if defined ('atype_inf`) || defined ('atype_nan`)
+ if (*msrc)
+ {
+#if defined ('atype_nan`)
+ non_empty_p = 1;
+ if (*src <= result)
+#endif
+ break;
+ }
+ }
+ if (__builtin_expect (n >= len, 0))
+ {
+#if defined ('atype_nan`)
+ result = non_empty_p ? atype_nan : atype_max;
+#else
+ result = atype_max;
+#endif
+ }
+ else for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+#endif
+ if (*msrc && *src < result)
+ result = *src;')
SCALAR_ARRAY_FUNCTION(atype_max)
--- libgfortran/m4/minloc0.m4.jj 2009-04-14 16:35:13.000000000 +0200
+++ libgfortran/m4/minloc0.m4 2009-07-22 17:19:24.000000000 +0200
@@ -34,28 +34,93 @@ include(iforeach.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
FOREACH_FUNCTION(
-` atype_name minval;
+` atype_name minval;
+#if defined('atype_nan`)
+ int fast = 0;
+#endif
- minval = atype_max;'
-,
-` if (*base < minval || !dest[0])
- {
- minval = *base;
- for (n = 0; n < rank; n++)
- dest[n * dstride] = count[n] + 1;
- }')
+#if defined('atype_inf`)
+ minval = atype_inf;
+#else
+ minval = atype_max;
+#endif',
+`#if defined('atype_nan`)
+ }
+ while (0);
+ if (__builtin_expect (!fast, 0))
+ {
+ do
+ {
+ if (*base <= minval)
+ {
+ fast = 1;
+ minval = *base;
+ for (n = 0; n < rank; n++)
+ dest[n * dstride] = count[n] + 1;
+ break;
+ }
+ base += sstride[0];
+ }
+ while (++count[0] != extent[0]);
+ if (__builtin_expect (fast, 1))
+ continue;
+ }
+ else do
+ {
+#endif
+ if (*base < minval)
+ {
+ minval = *base;
+ for (n = 0; n < rank; n++)
+ dest[n * dstride] = count[n] + 1;
+ }')
MASKED_FOREACH_FUNCTION(
` atype_name minval;
+ int fast = 0;
- minval = atype_max;'
-,
-` if (*mbase && (*base < minval || !dest[0]))
- {
- minval = *base;
- for (n = 0; n < rank; n++)
- dest[n * dstride] = count[n] + 1;
- }')
+#if defined('atype_inf`)
+ minval = atype_inf;
+#else
+ minval = atype_max;
+#endif',
+` }
+ while (0);
+ if (__builtin_expect (!fast, 0))
+ {
+ do
+ {
+ if (*mbase)
+ {
+#if defined('atype_nan`)
+ if (__builtin_expect (dest[0] == 0, 0))
+ for (n = 0; n < rank; n++)
+ dest[n * dstride] = count[n] + 1;
+ if (*base <= minval)
+#endif
+ {
+ fast = 1;
+ minval = *base;
+ for (n = 0; n < rank; n++)
+ dest[n * dstride] = count[n] + 1;
+ break;
+ }
+ }
+ base += sstride[0];
+ mbase += mstride[0];
+ }
+ while (++count[0] != extent[0]);
+ if (__builtin_expect (fast, 1))
+ continue;
+ }
+ else do
+ {
+ if (*mbase && *base < minval)
+ {
+ minval = *base;
+ for (n = 0; n < rank; n++)
+ dest[n * dstride] = count[n] + 1;
+ }')
SCALAR_FOREACH_FUNCTION(`0')
#endif
--- libgfortran/m4/maxval.m4.jj 2009-04-14 16:35:13.000000000 +0200
+++ libgfortran/m4/maxval.m4 2009-07-22 13:46:06.000000000 +0200
@@ -33,14 +33,55 @@ include(ifunction.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
ARRAY_FUNCTION(atype_min,
-` result = atype_min;',
-` if (*src > result)
- result = *src;')
+`#if defined ('atype_inf`)
+ result = -atype_inf;
+#else
+ result = atype_min;
+#endif',
+`#if defined ('atype_nan`)
+ if (*src >= result)
+ break;
+ }
+ if (__builtin_expect (n >= len, 0))
+ result = atype_nan;
+ else for (; n < len; n++, src += delta)
+ {
+#endif
+ if (*src > result)
+ result = *src;')
MASKED_ARRAY_FUNCTION(atype_min,
-` result = atype_min;',
-` if (*msrc && *src > result)
- result = *src;')
+`#if defined ('atype_inf`)
+ result = -atype_inf;
+#else
+ result = atype_min;
+#endif
+#if defined ('atype_nan`)
+ int non_empty_p = 0;
+#endif',
+`#if defined ('atype_inf`) || defined ('atype_nan`)
+ if (*msrc)
+ {
+#if defined ('atype_nan`)
+ non_empty_p = 1;
+ if (*src >= result)
+#endif
+ break;
+ }
+ }
+ if (__builtin_expect (n >= len, 0))
+ {
+#if defined ('atype_nan`)
+ result = non_empty_p ? atype_nan : atype_min;
+#else
+ result = atype_min;
+#endif
+ }
+ else for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+#endif
+ if (*msrc && *src > result)
+ result = *src;')
SCALAR_ARRAY_FUNCTION(atype_min)
--- libgfortran/m4/minloc1.m4.jj 2009-04-14 16:35:13.000000000 +0200
+++ libgfortran/m4/minloc1.m4 2009-07-22 10:56:03.000000000 +0200
@@ -34,24 +34,67 @@ include(ifunction.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
ARRAY_FUNCTION(0,
-` atype_name minval;
- minval = atype_max;
- result = 0;',
-` if (*src < minval || !result)
- {
- minval = *src;
- result = (rtype_name)n + 1;
- }')
+` atype_name minval;
+#if defined ('atype_inf`)
+ minval = atype_inf;
+#else
+ minval = atype_max;
+#endif
+ result = 1;',
+`#if defined ('atype_nan`)
+ if (*src <= minval)
+ {
+ minval = *src;
+ result = (rtype_name)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta)
+ {
+#endif
+ if (*src < minval)
+ {
+ minval = *src;
+ result = (rtype_name)n + 1;
+ }')
MASKED_ARRAY_FUNCTION(0,
-` atype_name minval;
- minval = atype_max;
- result = 0;',
-` if (*msrc && (*src < minval || !result))
- {
- minval = *src;
- result = (rtype_name)n + 1;
- }')
+` atype_name minval;
+#if defined ('atype_inf`)
+ minval = atype_inf;
+#else
+ minval = atype_max;
+#endif
+#if defined ('atype_nan`)
+ rtype_name result2 = 0;
+#endif
+ result = 0;',
+` if (*msrc)
+ {
+#if defined ('atype_nan`)
+ if (!result2)
+ result2 = (rtype_name)n + 1;
+ if (*src <= minval)
+#endif
+ {
+ minval = *src;
+ result = (rtype_name)n + 1;
+ break;
+ }
+ }
+ }
+#if defined ('atype_nan`)
+ if (__builtin_expect (n >= len, 0))
+ result = result2;
+ else
+#endif
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && *src < minval)
+ {
+ minval = *src;
+ result = (rtype_name)n + 1;
+ }')
SCALAR_ARRAY_FUNCTION(0)
--- libgfortran/m4/maxloc0.m4.jj 2009-04-14 16:35:13.000000000 +0200
+++ libgfortran/m4/maxloc0.m4 2009-07-22 17:34:38.000000000 +0200
@@ -34,28 +34,93 @@ include(iforeach.m4)dnl
`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
FOREACH_FUNCTION(
-` atype_name maxval;
+` atype_name maxval;
+#if defined('atype_nan`)
+ int fast = 0;
+#endif
- maxval = atype_min;'
-,
-` if (*base > maxval || !dest[0])
- {
- maxval = *base;
- for (n = 0; n < rank; n++)
- dest[n * dstride] = count[n] + 1;
- }')
+#if defined('atype_inf`)
+ maxval = -atype_inf;
+#else
+ maxval = atype_min;
+#endif',
+`#if defined('atype_nan`)
+ }
+ while (0);
+ if (__builtin_expect (!fast, 0))
+ {
+ do
+ {
+ if (*base >= maxval)
+ {
+ fast = 1;
+ maxval = *base;
+ for (n = 0; n < rank; n++)
+ dest[n * dstride] = count[n] + 1;
+ break;
+ }
+ base += sstride[0];
+ }
+ while (++count[0] != extent[0]);
+ if (__builtin_expect (fast, 1))
+ continue;
+ }
+ else do
+ {
+#endif
+ if (*base > maxval)
+ {
+ maxval = *base;
+ for (n = 0; n < rank; n++)
+ dest[n * dstride] = count[n] + 1;
+ }')
MASKED_FOREACH_FUNCTION(
` atype_name maxval;
+ int fast = 0;
- maxval = atype_min;'
-,
-` if (*mbase && (*base > maxval || !dest[0]))
- {
- maxval = *base;
- for (n = 0; n < rank; n++)
- dest[n * dstride] = count[n] + 1;
- }')
+#if defined('atype_inf`)
+ maxval = -atype_inf;
+#else
+ maxval = atype_min;
+#endif',
+` }
+ while (0);
+ if (__builtin_expect (!fast, 0))
+ {
+ do
+ {
+ if (*mbase)
+ {
+#if defined('atype_nan`)
+ if (__builtin_expect (dest[0] == 0, 0))
+ for (n = 0; n < rank; n++)
+ dest[n * dstride] = count[n] + 1;
+ if (*base >= maxval)
+#endif
+ {
+ fast = 1;
+ maxval = *base;
+ for (n = 0; n < rank; n++)
+ dest[n * dstride] = count[n] + 1;
+ break;
+ }
+ }
+ base += sstride[0];
+ mbase += mstride[0];
+ }
+ while (++count[0] != extent[0]);
+ if (__builtin_expect (fast, 1))
+ continue;
+ }
+ else do
+ {
+ if (*mbase && *base > maxval)
+ {
+ maxval = *base;
+ for (n = 0; n < rank; n++)
+ dest[n * dstride] = count[n] + 1;
+ }')
SCALAR_FOREACH_FUNCTION(`0')
#endif
--- gcc/testsuite/gfortran.dg/maxlocval_2.f90.jj 2009-07-22 17:45:44.000000000 +0200
+++ gcc/testsuite/gfortran.dg/maxlocval_2.f90 2009-07-22 17:45:44.000000000 +0200
@@ -0,0 +1,153 @@
+! { dg-do run }
+ real :: a(3), nan, minf, pinf
+ real, allocatable :: c(:)
+ logical :: l
+ logical :: l2(3)
+
+ nan = 0.0
+ minf = 0.0
+ pinf = 0.0
+ nan = 0.0/nan
+ minf = -1.0/minf
+ pinf = 1.0/pinf
+
+ allocate (c(3))
+ a(:) = nan
+ if (maxloc (a, dim = 1).ne.1) call abort
+ if (.not.isnan(maxval (a, dim = 1))) call abort
+ a(:) = minf
+ if (maxloc (a, dim = 1).ne.1) call abort
+ if (maxval (a, dim = 1).ne.minf) call abort
+ a(1:2) = nan
+ if (maxloc (a, dim = 1).ne.3) call abort
+ if (maxval (a, dim = 1).ne.minf) call abort
+ a(2) = 1.0
+ if (maxloc (a, dim = 1).ne.2) call abort
+ if (maxval (a, dim = 1).ne.1) call abort
+ a(2) = pinf
+ if (maxloc (a, dim = 1).ne.2) call abort
+ if (maxval (a, dim = 1).ne.pinf) call abort
+ c(:) = nan
+ if (maxloc (c, dim = 1).ne.1) call abort
+ if (.not.isnan(maxval (c, dim = 1))) call abort
+ c(:) = minf
+ if (maxloc (c, dim = 1).ne.1) call abort
+ if (maxval (c, dim = 1).ne.minf) call abort
+ c(1:2) = nan
+ if (maxloc (c, dim = 1).ne.3) call abort
+ if (maxval (c, dim = 1).ne.minf) call abort
+ c(2) = 1.0
+ if (maxloc (c, dim = 1).ne.2) call abort
+ if (maxval (c, dim = 1).ne.1) call abort
+ c(2) = pinf
+ if (maxloc (c, dim = 1).ne.2) call abort
+ if (maxval (c, dim = 1).ne.pinf) call abort
+ l = .false.
+ l2(:) = .false.
+ a(:) = nan
+ if (maxloc (a, dim = 1, mask = l).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l).ne.-huge(minf)) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.-huge(minf)) call abort
+ a(:) = minf
+ if (maxloc (a, dim = 1, mask = l).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l).ne.-huge(minf)) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.-huge(minf)) call abort
+ a(1:2) = nan
+ if (maxloc (a, dim = 1, mask = l).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l).ne.-huge(minf)) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.-huge(minf)) call abort
+ a(2) = 1.0
+ if (maxloc (a, dim = 1, mask = l).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l).ne.-huge(minf)) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.-huge(minf)) call abort
+ a(2) = pinf
+ if (maxloc (a, dim = 1, mask = l).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l).ne.-huge(minf)) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.-huge(minf)) call abort
+ c(:) = nan
+ if (maxloc (c, dim = 1, mask = l).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l).ne.-huge(minf)) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.-huge(minf)) call abort
+ c(:) = minf
+ if (maxloc (c, dim = 1, mask = l).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l).ne.-huge(minf)) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.-huge(minf)) call abort
+ c(1:2) = nan
+ if (maxloc (c, dim = 1, mask = l).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l).ne.-huge(minf)) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.-huge(minf)) call abort
+ c(2) = 1.0
+ if (maxloc (c, dim = 1, mask = l).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l).ne.-huge(minf)) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.-huge(minf)) call abort
+ c(2) = pinf
+ if (maxloc (c, dim = 1, mask = l).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l).ne.-huge(minf)) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.-huge(minf)) call abort
+ l = .true.
+ l2(:) = .true.
+ a(:) = nan
+ if (maxloc (a, dim = 1, mask = l).ne.1) call abort
+ if (.not.isnan(maxval (a, dim = 1, mask = l))) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.1) call abort
+ if (.not.isnan(maxval (a, dim = 1, mask = l2))) call abort
+ a(:) = minf
+ if (maxloc (a, dim = 1, mask = l).ne.1) call abort
+ if (maxval (a, dim = 1, mask = l).ne.minf) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.1) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.minf) call abort
+ a(1:2) = nan
+ if (maxloc (a, dim = 1, mask = l).ne.3) call abort
+ if (maxval (a, dim = 1, mask = l).ne.minf) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.3) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.minf) call abort
+ a(2) = 1.0
+ if (maxloc (a, dim = 1, mask = l).ne.2) call abort
+ if (maxval (a, dim = 1, mask = l).ne.1) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.2) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.1) call abort
+ a(2) = pinf
+ if (maxloc (a, dim = 1, mask = l).ne.2) call abort
+ if (maxval (a, dim = 1, mask = l).ne.pinf) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.2) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.pinf) call abort
+ c(:) = nan
+ if (maxloc (c, dim = 1, mask = l).ne.1) call abort
+ if (.not.isnan(maxval (c, dim = 1, mask = l))) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.1) call abort
+ if (.not.isnan(maxval (c, dim = 1, mask = l2))) call abort
+ c(:) = minf
+ if (maxloc (c, dim = 1, mask = l).ne.1) call abort
+ if (maxval (c, dim = 1, mask = l).ne.minf) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.1) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.minf) call abort
+ c(1:2) = nan
+ if (maxloc (c, dim = 1, mask = l).ne.3) call abort
+ if (maxval (c, dim = 1, mask = l).ne.minf) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.3) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.minf) call abort
+ c(2) = 1.0
+ if (maxloc (c, dim = 1, mask = l).ne.2) call abort
+ if (maxval (c, dim = 1, mask = l).ne.1) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.2) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.1) call abort
+ c(2) = pinf
+ if (maxloc (c, dim = 1, mask = l).ne.2) call abort
+ if (maxval (c, dim = 1, mask = l).ne.pinf) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.2) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.pinf) call abort
+ deallocate (c)
+ allocate (c(-2:-3))
+ if (maxloc (c, dim = 1).ne.0) call abort
+ if (maxval (c, dim = 1).ne.-huge(minf)) call abort
+end
--- gcc/testsuite/gfortran.dg/maxlocval_3.f90.jj 2009-07-22 17:45:44.000000000 +0200
+++ gcc/testsuite/gfortran.dg/maxlocval_3.f90 2009-07-22 17:45:44.000000000 +0200
@@ -0,0 +1,122 @@
+! { dg-do run }
+ integer :: a(3), h
+ integer, allocatable :: c(:)
+ logical :: l
+ logical :: l2(3)
+
+ h = -huge(h)
+ h = h - 1
+ allocate (c(3))
+ a(:) = 5
+ if (maxloc (a, dim = 1).ne.1) call abort
+ if (maxval (a, dim = 1).ne.5) call abort
+ a(2) = huge(h)
+ if (maxloc (a, dim = 1).ne.2) call abort
+ if (maxval (a, dim = 1).ne.huge(h)) call abort
+ a(:) = h
+ if (maxloc (a, dim = 1).ne.1) call abort
+ if (maxval (a, dim = 1).ne.h) call abort
+ a(3) = -huge(h)
+ if (maxloc (a, dim = 1).ne.3) call abort
+ if (maxval (a, dim = 1).ne.-huge(h)) call abort
+ c(:) = 5
+ if (maxloc (c, dim = 1).ne.1) call abort
+ if (maxval (c, dim = 1).ne.5) call abort
+ c(2) = huge(h)
+ if (maxloc (c, dim = 1).ne.2) call abort
+ if (maxval (c, dim = 1).ne.huge(h)) call abort
+ c(:) = h
+ if (maxloc (c, dim = 1).ne.1) call abort
+ if (maxval (c, dim = 1).ne.h) call abort
+ c(3) = -huge(h)
+ if (maxloc (c, dim = 1).ne.3) call abort
+ if (maxval (c, dim = 1).ne.-huge(h)) call abort
+ l = .false.
+ l2(:) = .false.
+ a(:) = 5
+ if (maxloc (a, dim = 1, mask = l).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l).ne.h) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.h) call abort
+ a(2) = huge(h)
+ if (maxloc (a, dim = 1, mask = l).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l).ne.h) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.h) call abort
+ a(:) = h
+ if (maxloc (a, dim = 1, mask = l).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l).ne.h) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.h) call abort
+ a(3) = -huge(h)
+ if (maxloc (a, dim = 1, mask = l).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l).ne.h) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.h) call abort
+ c(:) = 5
+ if (maxloc (c, dim = 1, mask = l).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l).ne.h) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.h) call abort
+ c(2) = huge(h)
+ if (maxloc (c, dim = 1, mask = l).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l).ne.h) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.h) call abort
+ c(:) = h
+ if (maxloc (c, dim = 1, mask = l).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l).ne.h) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.h) call abort
+ c(3) = -huge(h)
+ if (maxloc (c, dim = 1, mask = l).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l).ne.h) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.h) call abort
+ l = .true.
+ l2(:) = .true.
+ a(:) = 5
+ if (maxloc (a, dim = 1, mask = l).ne.1) call abort
+ if (maxval (a, dim = 1, mask = l).ne.5) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.1) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.5) call abort
+ a(2) = huge(h)
+ if (maxloc (a, dim = 1, mask = l).ne.2) call abort
+ if (maxval (a, dim = 1, mask = l).ne.huge(h)) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.2) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.huge(h)) call abort
+ a(:) = h
+ if (maxloc (a, dim = 1, mask = l).ne.1) call abort
+ if (maxval (a, dim = 1, mask = l).ne.h) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.1) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.h) call abort
+ a(3) = -huge(h)
+ if (maxloc (a, dim = 1, mask = l).ne.3) call abort
+ if (maxval (a, dim = 1, mask = l).ne.-huge(h)) call abort
+ if (maxloc (a, dim = 1, mask = l2).ne.3) call abort
+ if (maxval (a, dim = 1, mask = l2).ne.-huge(h)) call abort
+ c(:) = 5
+ if (maxloc (c, dim = 1, mask = l).ne.1) call abort
+ if (maxval (c, dim = 1, mask = l).ne.5) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.1) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.5) call abort
+ c(2) = huge(h)
+ if (maxloc (c, dim = 1, mask = l).ne.2) call abort
+ if (maxval (c, dim = 1, mask = l).ne.huge(h)) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.2) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.huge(h)) call abort
+ c(:) = h
+ if (maxloc (c, dim = 1, mask = l).ne.1) call abort
+ if (maxval (c, dim = 1, mask = l).ne.h) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.1) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.h) call abort
+ c(3) = -huge(h)
+ if (maxloc (c, dim = 1, mask = l).ne.3) call abort
+ if (maxval (c, dim = 1, mask = l).ne.-huge(h)) call abort
+ if (maxloc (c, dim = 1, mask = l2).ne.3) call abort
+ if (maxval (c, dim = 1, mask = l2).ne.-huge(h)) call abort
+ deallocate (c)
+ allocate (c(-2:-3))
+ if (maxloc (c, dim = 1).ne.0) call abort
+ if (maxval (c, dim = 1).ne.h) call abort
+end
--- gcc/testsuite/gfortran.dg/maxlocval_4.f90.jj 2009-07-22 19:29:07.000000000 +0200
+++ gcc/testsuite/gfortran.dg/maxlocval_4.f90 2009-07-22 19:30:19.000000000 +0200
@@ -0,0 +1,118 @@
+! { dg-do run }
+ real :: a(3,3), b(3), nan, minf, pinf, h
+ logical :: l, l2
+ logical :: l3(3,3), l4(3,3), l5(3,3)
+
+ nan = 0.0
+ minf = 0.0
+ pinf = 0.0
+ nan = 0.0/nan
+ minf = -1.0/minf
+ pinf = 1.0/pinf
+ h = -huge(h)
+ l = .false.
+ l2 = .true.
+ l3 = .false.
+ l4 = .true.
+ l5 = .true.
+ l5(1,1) = .false.
+ l5(1,2) = .false.
+ l5(2,3) = .false.
+ a = reshape ((/ nan, nan, nan, minf, minf, minf, minf, pinf, minf /), (/ 3, 3 /))
+ if (maxval (a).ne.pinf) call abort
+ if (any (maxloc (a).ne.(/ 2, 3 /))) call abort
+ b = maxval (a, dim = 1)
+ if (.not.isnan(b(1))) call abort
+ b(1) = 0.0
+ if (any (b.ne.(/ 0.0, minf, pinf /))) call abort
+ if (any (maxloc (a, dim = 1).ne.(/ 1, 1, 2 /))) call abort
+ b = maxval (a, dim = 2)
+ if (any (b.ne.(/ minf, pinf, minf /))) call abort
+ if (any (maxloc (a, dim = 2).ne.(/ 2, 3, 2 /))) call abort
+ if (maxval (a, mask = l).ne.h) call abort
+ if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) call abort
+ b = maxval (a, dim = 1, mask = l)
+ if (any (b.ne.(/ h, h, h /))) call abort
+ if (any (maxloc (a, dim = 1, mask = l).ne.(/ 0, 0, 0 /))) call abort
+ b = maxval (a, dim = 2, mask = l)
+ if (any (b.ne.(/ h, h, h /))) call abort
+ if (any (maxloc (a, dim = 2, mask = l).ne.(/ 0, 0, 0 /))) call abort
+ if (maxval (a, mask = l3).ne.h) call abort
+ if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
+ b = maxval (a, dim = 1, mask = l3)
+ if (any (b.ne.(/ h, h, h /))) call abort
+ if (any (maxloc (a, dim = 1, mask = l3).ne.(/ 0, 0, 0 /))) call abort
+ b = maxval (a, dim = 2, mask = l3)
+ if (any (b.ne.(/ h, h, h /))) call abort
+ if (any (maxloc (a, dim = 2, mask = l3).ne.(/ 0, 0, 0 /))) call abort
+ if (maxval (a, mask = l2).ne.pinf) call abort
+ if (maxval (a, mask = l4).ne.pinf) call abort
+ if (any (maxloc (a, mask = l2).ne.(/ 2, 3 /))) call abort
+ if (any (maxloc (a, mask = l4).ne.(/ 2, 3 /))) call abort
+ b = maxval (a, dim = 1, mask = l2)
+ if (.not.isnan(b(1))) call abort
+ b(1) = 0.0
+ if (any (b.ne.(/ 0.0, minf, pinf /))) call abort
+ if (any (maxloc (a, dim = 1, mask = l2).ne.(/ 1, 1, 2 /))) call abort
+ b = maxval (a, dim = 2, mask = l2)
+ if (any (b.ne.(/ minf, pinf, minf /))) call abort
+ if (any (maxloc (a, dim = 2, mask = l2).ne.(/ 2, 3, 2 /))) call abort
+ b = maxval (a, dim = 1, mask = l4)
+ if (.not.isnan(b(1))) call abort
+ b(1) = 0.0
+ if (any (b.ne.(/ 0.0, minf, pinf /))) call abort
+ if (any (maxloc (a, dim = 1, mask = l2).ne.(/ 1, 1, 2 /))) call abort
+ b = maxval (a, dim = 2, mask = l4)
+ if (any (b.ne.(/ minf, pinf, minf /))) call abort
+ if (any (maxloc (a, dim = 2, mask = l2).ne.(/ 2, 3, 2 /))) call abort
+ if (maxval (a, mask = l5).ne.minf) call abort
+ if (any (maxloc (a, mask = l5).ne.(/ 2, 2 /))) call abort
+ b = maxval (a, dim = 1, mask = l5)
+ if (.not.isnan(b(1))) call abort
+ b(1) = 0.0
+ if (any (b.ne.(/ 0.0, minf, minf /))) call abort
+ if (any (maxloc (a, dim = 1, mask = l5).ne.(/ 2, 2, 1 /))) call abort
+ b = maxval (a, dim = 2, mask = l5)
+ if (any (b.ne.(/ minf, minf, minf /))) call abort
+ if (any (maxloc (a, dim = 2, mask = l5).ne.(/ 3, 2, 2 /))) call abort
+ a = nan
+ if (.not.isnan(maxval (a))) call abort
+ if (maxval (a, mask = l).ne.h) call abort
+ if (.not.isnan(maxval (a, mask = l2))) call abort
+ if (maxval (a, mask = l3).ne.h) call abort
+ if (.not.isnan(maxval (a, mask = l4))) call abort
+ if (.not.isnan(maxval (a, mask = l5))) call abort
+ if (any (maxloc (a).ne.(/ 1, 1 /))) call abort
+ if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) call abort
+ if (any (maxloc (a, mask = l2).ne.(/ 1, 1 /))) call abort
+ if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
+ if (any (maxloc (a, mask = l4).ne.(/ 1, 1 /))) call abort
+ if (any (maxloc (a, mask = l5).ne.(/ 2, 1 /))) call abort
+ a = minf
+ if (maxval (a).ne.minf) call abort
+ if (maxval (a, mask = l).ne.h) call abort
+ if (maxval (a, mask = l2).ne.minf) call abort
+ if (maxval (a, mask = l3).ne.h) call abort
+ if (maxval (a, mask = l4).ne.minf) call abort
+ if (maxval (a, mask = l5).ne.minf) call abort
+ if (any (maxloc (a).ne.(/ 1, 1 /))) call abort
+ if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) call abort
+ if (any (maxloc (a, mask = l2).ne.(/ 1, 1 /))) call abort
+ if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
+ if (any (maxloc (a, mask = l4).ne.(/ 1, 1 /))) call abort
+ if (any (maxloc (a, mask = l5).ne.(/ 2, 1 /))) call abort
+ a = nan
+ a(1,3) = minf
+ if (maxval (a).ne.minf) call abort
+ if (maxval (a, mask = l).ne.h) call abort
+ if (maxval (a, mask = l2).ne.minf) call abort
+ if (maxval (a, mask = l3).ne.h) call abort
+ if (maxval (a, mask = l4).ne.minf) call abort
+ if (maxval (a, mask = l5).ne.minf) call abort
+ if (any (maxloc (a).ne.(/ 1, 3 /))) call abort
+ if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) call abort
+ if (any (maxloc (a, mask = l2).ne.(/ 1, 3 /))) call abort
+ if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
+ if (any (maxloc (a, mask = l4).ne.(/ 1, 3 /))) call abort
+ if (any (maxloc (a, mask = l5).ne.(/ 1, 3 /))) call abort
+end
--- gcc/testsuite/gfortran.dg/minlocval_1.f90.jj 2009-07-22 17:45:44.000000000 +0200
+++ gcc/testsuite/gfortran.dg/minlocval_1.f90 2009-07-22 17:45:44.000000000 +0200
@@ -0,0 +1,153 @@
+! { dg-do run }
+ real :: a(3), nan, minf, pinf
+ real, allocatable :: c(:)
+ logical :: l
+ logical :: l2(3)
+
+ nan = 0.0
+ minf = 0.0
+ pinf = 0.0
+ nan = 0.0/nan
+ minf = -1.0/minf
+ pinf = 1.0/pinf
+
+ allocate (c(3))
+ a(:) = nan
+ if (minloc (a, dim = 1).ne.1) call abort
+ if (.not.isnan(minval (a, dim = 1))) call abort
+ a(:) = pinf
+ if (minloc (a, dim = 1).ne.1) call abort
+ if (minval (a, dim = 1).ne.pinf) call abort
+ a(1:2) = nan
+ if (minloc (a, dim = 1).ne.3) call abort
+ if (minval (a, dim = 1).ne.pinf) call abort
+ a(2) = 1.0
+ if (minloc (a, dim = 1).ne.2) call abort
+ if (minval (a, dim = 1).ne.1) call abort
+ a(2) = minf
+ if (minloc (a, dim = 1).ne.2) call abort
+ if (minval (a, dim = 1).ne.minf) call abort
+ c(:) = nan
+ if (minloc (c, dim = 1).ne.1) call abort
+ if (.not.isnan(minval (c, dim = 1))) call abort
+ c(:) = pinf
+ if (minloc (c, dim = 1).ne.1) call abort
+ if (minval (c, dim = 1).ne.pinf) call abort
+ c(1:2) = nan
+ if (minloc (c, dim = 1).ne.3) call abort
+ if (minval (c, dim = 1).ne.pinf) call abort
+ c(2) = 1.0
+ if (minloc (c, dim = 1).ne.2) call abort
+ if (minval (c, dim = 1).ne.1) call abort
+ c(2) = minf
+ if (minloc (c, dim = 1).ne.2) call abort
+ if (minval (c, dim = 1).ne.minf) call abort
+ l = .false.
+ l2(:) = .false.
+ a(:) = nan
+ if (minloc (a, dim = 1, mask = l).ne.0) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(pinf)) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(pinf)) call abort
+ a(:) = pinf
+ if (minloc (a, dim = 1, mask = l).ne.0) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(pinf)) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(pinf)) call abort
+ a(1:2) = nan
+ if (minloc (a, dim = 1, mask = l).ne.0) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(pinf)) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(pinf)) call abort
+ a(2) = 1.0
+ if (minloc (a, dim = 1, mask = l).ne.0) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(pinf)) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(pinf)) call abort
+ a(2) = minf
+ if (minloc (a, dim = 1, mask = l).ne.0) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(pinf)) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(pinf)) call abort
+ c(:) = nan
+ if (minloc (c, dim = 1, mask = l).ne.0) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(pinf)) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(pinf)) call abort
+ c(:) = pinf
+ if (minloc (c, dim = 1, mask = l).ne.0) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(pinf)) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(pinf)) call abort
+ c(1:2) = nan
+ if (minloc (c, dim = 1, mask = l).ne.0) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(pinf)) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(pinf)) call abort
+ c(2) = 1.0
+ if (minloc (c, dim = 1, mask = l).ne.0) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(pinf)) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(pinf)) call abort
+ c(2) = minf
+ if (minloc (c, dim = 1, mask = l).ne.0) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(pinf)) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(pinf)) call abort
+ l = .true.
+ l2(:) = .true.
+ a(:) = nan
+ if (minloc (a, dim = 1, mask = l).ne.1) call abort
+ if (.not.isnan(minval (a, dim = 1, mask = l))) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.1) call abort
+ if (.not.isnan(minval (a, dim = 1, mask = l2))) call abort
+ a(:) = pinf
+ if (minloc (a, dim = 1, mask = l).ne.1) call abort
+ if (minval (a, dim = 1, mask = l).ne.pinf) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.1) call abort
+ if (minval (a, dim = 1, mask = l2).ne.pinf) call abort
+ a(1:2) = nan
+ if (minloc (a, dim = 1, mask = l).ne.3) call abort
+ if (minval (a, dim = 1, mask = l).ne.pinf) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.3) call abort
+ if (minval (a, dim = 1, mask = l2).ne.pinf) call abort
+ a(2) = 1.0
+ if (minloc (a, dim = 1, mask = l).ne.2) call abort
+ if (minval (a, dim = 1, mask = l).ne.1) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.2) call abort
+ if (minval (a, dim = 1, mask = l2).ne.1) call abort
+ a(2) = minf
+ if (minloc (a, dim = 1, mask = l).ne.2) call abort
+ if (minval (a, dim = 1, mask = l).ne.minf) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.2) call abort
+ if (minval (a, dim = 1, mask = l2).ne.minf) call abort
+ c(:) = nan
+ if (minloc (c, dim = 1, mask = l).ne.1) call abort
+ if (.not.isnan(minval (c, dim = 1, mask = l))) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.1) call abort
+ if (.not.isnan(minval (c, dim = 1, mask = l2))) call abort
+ c(:) = pinf
+ if (minloc (c, dim = 1, mask = l).ne.1) call abort
+ if (minval (c, dim = 1, mask = l).ne.pinf) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.1) call abort
+ if (minval (c, dim = 1, mask = l2).ne.pinf) call abort
+ c(1:2) = nan
+ if (minloc (c, dim = 1, mask = l).ne.3) call abort
+ if (minval (c, dim = 1, mask = l).ne.pinf) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.3) call abort
+ if (minval (c, dim = 1, mask = l2).ne.pinf) call abort
+ c(2) = 1.0
+ if (minloc (c, dim = 1, mask = l).ne.2) call abort
+ if (minval (c, dim = 1, mask = l).ne.1) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.2) call abort
+ if (minval (c, dim = 1, mask = l2).ne.1) call abort
+ c(2) = minf
+ if (minloc (c, dim = 1, mask = l).ne.2) call abort
+ if (minval (c, dim = 1, mask = l).ne.minf) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.2) call abort
+ if (minval (c, dim = 1, mask = l2).ne.minf) call abort
+ deallocate (c)
+ allocate (c(-2:-3))
+ if (minloc (c, dim = 1).ne.0) call abort
+ if (minval (c, dim = 1).ne.huge(pinf)) call abort
+end
--- gcc/testsuite/gfortran.dg/minlocval_2.f90.jj 2009-07-22 17:45:44.000000000 +0200
+++ gcc/testsuite/gfortran.dg/minlocval_2.f90 2009-07-22 17:45:44.000000000 +0200
@@ -0,0 +1,122 @@
+! { dg-do run }
+ integer :: a(3), h
+ integer, allocatable :: c(:)
+ logical :: l
+ logical :: l2(3)
+
+ h = -huge(h)
+ h = h - 1
+ allocate (c(3))
+ a(:) = 5
+ if (minloc (a, dim = 1).ne.1) call abort
+ if (minval (a, dim = 1).ne.5) call abort
+ a(2) = h
+ if (minloc (a, dim = 1).ne.2) call abort
+ if (minval (a, dim = 1).ne.h) call abort
+ a(:) = huge(h)
+ if (minloc (a, dim = 1).ne.1) call abort
+ if (minval (a, dim = 1).ne.huge(h)) call abort
+ a(3) = huge(h) - 1
+ if (minloc (a, dim = 1).ne.3) call abort
+ if (minval (a, dim = 1).ne.huge(h)-1) call abort
+ c(:) = 5
+ if (minloc (c, dim = 1).ne.1) call abort
+ if (minval (c, dim = 1).ne.5) call abort
+ c(2) = h
+ if (minloc (c, dim = 1).ne.2) call abort
+ if (minval (c, dim = 1).ne.h) call abort
+ c(:) = huge(h)
+ if (minloc (c, dim = 1).ne.1) call abort
+ if (minval (c, dim = 1).ne.huge(h)) call abort
+ c(3) = huge(h) - 1
+ if (minloc (c, dim = 1).ne.3) call abort
+ if (minval (c, dim = 1).ne.huge(h)-1) call abort
+ l = .false.
+ l2(:) = .false.
+ a(:) = 5
+ if (minloc (a, dim = 1, mask = l).ne.0) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(h)) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(h)) call abort
+ a(2) = h
+ if (minloc (a, dim = 1, mask = l).ne.0) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(h)) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(h)) call abort
+ a(:) = huge(h)
+ if (minloc (a, dim = 1, mask = l).ne.0) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(h)) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(h)) call abort
+ a(3) = huge(h) - 1
+ if (minloc (a, dim = 1, mask = l).ne.0) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(h)) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.0) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(h)) call abort
+ c(:) = 5
+ if (minloc (c, dim = 1, mask = l).ne.0) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(h)) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(h)) call abort
+ c(2) = h
+ if (minloc (c, dim = 1, mask = l).ne.0) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(h)) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(h)) call abort
+ c(:) = huge(h)
+ if (minloc (c, dim = 1, mask = l).ne.0) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(h)) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(h)) call abort
+ c(3) = huge(h) - 1
+ if (minloc (c, dim = 1, mask = l).ne.0) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(h)) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.0) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(h)) call abort
+ l = .true.
+ l2(:) = .true.
+ a(:) = 5
+ if (minloc (a, dim = 1, mask = l).ne.1) call abort
+ if (minval (a, dim = 1, mask = l).ne.5) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.1) call abort
+ if (minval (a, dim = 1, mask = l2).ne.5) call abort
+ a(2) = h
+ if (minloc (a, dim = 1, mask = l).ne.2) call abort
+ if (minval (a, dim = 1, mask = l).ne.h) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.2) call abort
+ if (minval (a, dim = 1, mask = l2).ne.h) call abort
+ a(:) = huge(h)
+ if (minloc (a, dim = 1, mask = l).ne.1) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(h)) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.1) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(h)) call abort
+ a(3) = huge(h) - 1
+ if (minloc (a, dim = 1, mask = l).ne.3) call abort
+ if (minval (a, dim = 1, mask = l).ne.huge(h)-1) call abort
+ if (minloc (a, dim = 1, mask = l2).ne.3) call abort
+ if (minval (a, dim = 1, mask = l2).ne.huge(h)-1) call abort
+ c(:) = 5
+ if (minloc (c, dim = 1, mask = l).ne.1) call abort
+ if (minval (c, dim = 1, mask = l).ne.5) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.1) call abort
+ if (minval (c, dim = 1, mask = l2).ne.5) call abort
+ c(2) = h
+ if (minloc (c, dim = 1, mask = l).ne.2) call abort
+ if (minval (c, dim = 1, mask = l).ne.h) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.2) call abort
+ if (minval (c, dim = 1, mask = l2).ne.h) call abort
+ c(:) = huge(h)
+ if (minloc (c, dim = 1, mask = l).ne.1) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(h)) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.1) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(h)) call abort
+ c(3) = huge(h) - 1
+ if (minloc (c, dim = 1, mask = l).ne.3) call abort
+ if (minval (c, dim = 1, mask = l).ne.huge(h)-1) call abort
+ if (minloc (c, dim = 1, mask = l2).ne.3) call abort
+ if (minval (c, dim = 1, mask = l2).ne.huge(h)-1) call abort
+ deallocate (c)
+ allocate (c(-2:-3))
+ if (minloc (c, dim = 1).ne.0) call abort
+ if (minval (c, dim = 1).ne.huge(h)) call abort
+end
--- gcc/testsuite/gfortran.dg/minlocval_3.f90.jj 2009-07-22 17:45:44.000000000 +0200
+++ gcc/testsuite/gfortran.dg/minlocval_3.f90 2009-07-22 17:45:44.000000000 +0200
@@ -0,0 +1,284 @@
+ real :: a(30), b(10, 10), m
+ real, allocatable :: c(:), d(:, :)
+ integer :: e(30), f(10, 10), n
+ integer, allocatable :: g(:), h(:,:)
+ logical :: l(30), l2(10, 10)
+ allocate (c (30))
+ allocate (d (10, 10))
+ allocate (g (30))
+ allocate (h (10, 10))
+ a = 7.0
+ b = 7.0
+ c = 7.0
+ d = 7.0
+ e = 7
+ f = 7
+ g = 7
+ h = 7
+ m = huge(m)
+ n = huge(n)
+ a(7) = 6.0
+ b(5, 5) = 6.0
+ b(5, 6) = 5.0
+ b(6, 7) = 4.0
+ c(7) = 6.0
+ d(5, 5) = 6.0
+ d(5, 6) = 5.0
+ d(6, 7) = 4.0
+ e(7) = 6
+ f(5, 5) = 6
+ f(5, 6) = 5
+ f(6, 7) = 4
+ g(7) = 6
+ h(5, 5) = 6
+ h(5, 6) = 5
+ h(6, 7) = 4
+ if (minloc (a, dim = 1).ne.7) call abort
+ if (minval (a, dim = 1).ne.6.0) call abort
+ if (minloc (a(::2), dim = 1).ne.4) call abort
+ if (minval (a(::2), dim = 1).ne.6.0) call abort
+ if (any (minloc (a).ne.(/ 7 /))) call abort
+ if (minval (a).ne.6.0) call abort
+ if (any (minloc (a(::2)).ne.(/ 4 /))) call abort
+ if (minval (a(::2)).ne.6.0) call abort
+ if (any (minloc (b, dim = 1).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) call abort
+ if (any (minval (b, dim = 1).ne.(/ 7.0, 7.0, 7.0, 7.0, 6.0, 5.0, 4.0, 7.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (b(::2,::2), dim = 1).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (b(::2,::2), dim = 1).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (b, dim = 2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) call abort
+ if (any (minval (b, dim = 2).ne.(/ 7.0, 7.0, 7.0, 7.0, 5.0, 4.0, 7.0, 7.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (b(::2,::2), dim = 2).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (b(::2,::2), dim = 2).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (b).ne.(/ 6, 7 /))) call abort
+ if (minval (b).ne.4.0) call abort
+ if (any (minloc (b(::2,::2)).ne.(/ 3, 3 /))) call abort
+ if (minval (b(::2,::2)).ne.6.0) call abort
+ if (minloc (c, dim = 1).ne.7) call abort
+ if (minval (c, dim = 1).ne.6.0) call abort
+ if (minloc (c(::2), dim = 1).ne.4) call abort
+ if (minval (c(::2), dim = 1).ne.6.0) call abort
+ if (any (minloc (c).ne.(/ 7 /))) call abort
+ if (minval (c).ne.6.0) call abort
+ if (any (minloc (c(::2)).ne.(/ 4 /))) call abort
+ if (minval (c(::2)).ne.6.0) call abort
+ if (any (minloc (d, dim = 1).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) call abort
+ if (any (minval (d, dim = 1).ne.(/ 7.0, 7.0, 7.0, 7.0, 6.0, 5.0, 4.0, 7.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (d(::2,::2), dim = 1).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (d(::2,::2), dim = 1).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (d, dim = 2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) call abort
+ if (any (minval (d, dim = 2).ne.(/ 7.0, 7.0, 7.0, 7.0, 5.0, 4.0, 7.0, 7.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (d(::2,::2), dim = 2).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (d(::2,::2), dim = 2).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (d).ne.(/ 6, 7 /))) call abort
+ if (minval (d).ne.4.0) call abort
+ if (any (minloc (d(::2,::2)).ne.(/ 3, 3 /))) call abort
+ if (minval (d(::2,::2)).ne.6.0) call abort
+ if (minloc (e, dim = 1).ne.7) call abort
+ if (minval (e, dim = 1).ne.6) call abort
+ if (minloc (e(::2), dim = 1).ne.4) call abort
+ if (minval (e(::2), dim = 1).ne.6) call abort
+ if (any (minloc (e).ne.(/ 7 /))) call abort
+ if (minval (e).ne.6) call abort
+ if (any (minloc (e(::2)).ne.(/ 4 /))) call abort
+ if (minval (e(::2)).ne.6) call abort
+ if (any (minloc (f, dim = 1).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) call abort
+ if (any (minval (f, dim = 1).ne.(/ 7, 7, 7, 7, 6, 5, 4, 7, 7, 7 /))) call abort
+ if (any (minloc (f(::2,::2), dim = 1).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (f(::2,::2), dim = 1).ne.(/ 7, 7, 6, 7, 7 /))) call abort
+ if (any (minloc (f, dim = 2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) call abort
+ if (any (minval (f, dim = 2).ne.(/ 7, 7, 7, 7, 5, 4, 7, 7, 7, 7 /))) call abort
+ if (any (minloc (f(::2,::2), dim = 2).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (f(::2,::2), dim = 2).ne.(/ 7, 7, 6, 7, 7 /))) call abort
+ if (any (minloc (f).ne.(/ 6, 7 /))) call abort
+ if (minval (f).ne.4) call abort
+ if (any (minloc (f(::2,::2)).ne.(/ 3, 3 /))) call abort
+ if (minval (f(::2,::2)).ne.6) call abort
+ if (minloc (g, dim = 1).ne.7) call abort
+ if (minval (g, dim = 1).ne.6) call abort
+ if (minloc (g(::2), dim = 1).ne.4) call abort
+ if (minval (g(::2), dim = 1).ne.6) call abort
+ if (any (minloc (g).ne.(/ 7 /))) call abort
+ if (minval (g).ne.6) call abort
+ if (any (minloc (g(::2)).ne.(/ 4 /))) call abort
+ if (minval (g(::2)).ne.6) call abort
+ if (any (minloc (h, dim = 1).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) call abort
+ if (any (minval (h, dim = 1).ne.(/ 7, 7, 7, 7, 6, 5, 4, 7, 7, 7 /))) call abort
+ if (any (minloc (h(::2,::2), dim = 1).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (h(::2,::2), dim = 1).ne.(/ 7, 7, 6, 7, 7 /))) call abort
+ if (any (minloc (h, dim = 2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) call abort
+ if (any (minval (h, dim = 2).ne.(/ 7, 7, 7, 7, 5, 4, 7, 7, 7, 7 /))) call abort
+ if (any (minloc (h(::2,::2), dim = 2).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (h(::2,::2), dim = 2).ne.(/ 7, 7, 6, 7, 7 /))) call abort
+ if (any (minloc (h).ne.(/ 6, 7 /))) call abort
+ if (minval (h).ne.4) call abort
+ if (any (minloc (h(::2,::2)).ne.(/ 3, 3 /))) call abort
+ if (minval (h(::2,::2)).ne.6) call abort
+ l = .true.
+ l2 = .true.
+ if (minloc (a, dim = 1, mask = l).ne.7) call abort
+ if (minval (a, dim = 1, mask = l).ne.6.0) call abort
+ if (minloc (a(::2), dim = 1, mask = l(::2)).ne.4) call abort
+ if (minval (a(::2), dim = 1, mask = l(::2)).ne.6.0) call abort
+ if (any (minloc (a, mask = l).ne.(/ 7 /))) call abort
+ if (minval (a, mask = l).ne.6.0) call abort
+ if (any (minloc (a(::2), mask = l(::2)).ne.(/ 4 /))) call abort
+ if (minval (a(::2), mask = l(::2)).ne.6.0) call abort
+ if (any (minloc (b, dim = 1, mask = l2).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) call abort
+ if (any (minval (b, dim = 1, mask = l2).ne.(/ 7.0, 7.0, 7.0, 7.0, 6.0, 5.0, 4.0, 7.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (b(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (b(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (b, dim = 2, mask = l2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) call abort
+ if (any (minval (b, dim = 2, mask = l2).ne.(/ 7.0, 7.0, 7.0, 7.0, 5.0, 4.0, 7.0, 7.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (b(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (b(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (b, mask = l2).ne.(/ 6, 7 /))) call abort
+ if (minval (b, mask = l2).ne.4.0) call abort
+ if (any (minloc (b(::2,::2), mask = l2(::2,::2)).ne.(/ 3, 3 /))) call abort
+ if (minval (b(::2,::2), mask = l2(::2,::2)).ne.6.0) call abort
+ if (minloc (c, dim = 1, mask = l).ne.7) call abort
+ if (minval (c, dim = 1, mask = l).ne.6.0) call abort
+ if (minloc (c(::2), dim = 1, mask = l(::2)).ne.4) call abort
+ if (minval (c(::2), dim = 1, mask = l(::2)).ne.6.0) call abort
+ if (any (minloc (c, mask = l).ne.(/ 7 /))) call abort
+ if (minval (c, mask = l).ne.6.0) call abort
+ if (any (minloc (c(::2), mask = l(::2)).ne.(/ 4 /))) call abort
+ if (minval (c(::2), mask = l(::2)).ne.6.0) call abort
+ if (any (minloc (d, dim = 1, mask = l2).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) call abort
+ if (any (minval (d, dim = 1, mask = l2).ne.(/ 7.0, 7.0, 7.0, 7.0, 6.0, 5.0, 4.0, 7.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (d(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (d(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (d, dim = 2, mask = l2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) call abort
+ if (any (minval (d, dim = 2, mask = l2).ne.(/ 7.0, 7.0, 7.0, 7.0, 5.0, 4.0, 7.0, 7.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (d(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (d(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 7.0, 7.0, 6.0, 7.0, 7.0 /))) call abort
+ if (any (minloc (d, mask = l2).ne.(/ 6, 7 /))) call abort
+ if (minval (d, mask = l2).ne.4.0) call abort
+ if (any (minloc (d(::2,::2), mask = l2(::2,::2)).ne.(/ 3, 3 /))) call abort
+ if (minval (d(::2,::2), mask = l2(::2,::2)).ne.6.0) call abort
+ if (minloc (e, dim = 1, mask = l).ne.7) call abort
+ if (minval (e, dim = 1, mask = l).ne.6) call abort
+ if (minloc (e(::2), dim = 1, mask = l(::2)).ne.4) call abort
+ if (minval (e(::2), dim = 1, mask = l(::2)).ne.6) call abort
+ if (any (minloc (e, mask = l).ne.(/ 7 /))) call abort
+ if (minval (e, mask = l).ne.6) call abort
+ if (any (minloc (e(::2), mask = l(::2)).ne.(/ 4 /))) call abort
+ if (minval (e(::2), mask = l(::2)).ne.6) call abort
+ if (any (minloc (f, dim = 1, mask = l2).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) call abort
+ if (any (minval (f, dim = 1, mask = l2).ne.(/ 7, 7, 7, 7, 6, 5, 4, 7, 7, 7 /))) call abort
+ if (any (minloc (f(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (f(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 7, 7, 6, 7, 7 /))) call abort
+ if (any (minloc (f, dim = 2, mask = l2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) call abort
+ if (any (minval (f, dim = 2, mask = l2).ne.(/ 7, 7, 7, 7, 5, 4, 7, 7, 7, 7 /))) call abort
+ if (any (minloc (f(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (f(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 7, 7, 6, 7, 7 /))) call abort
+ if (any (minloc (f, mask = l2).ne.(/ 6, 7 /))) call abort
+ if (minval (f, mask = l2).ne.4) call abort
+ if (any (minloc (f(::2,::2), mask = l2(::2,::2)).ne.(/ 3, 3 /))) call abort
+ if (minval (f(::2,::2), mask = l2(::2,::2)).ne.6) call abort
+ if (minloc (g, dim = 1, mask = l).ne.7) call abort
+ if (minval (g, dim = 1, mask = l).ne.6) call abort
+ if (minloc (g(::2), dim = 1, mask = l(::2)).ne.4) call abort
+ if (minval (g(::2), dim = 1, mask = l(::2)).ne.6) call abort
+ if (any (minloc (g, mask = l).ne.(/ 7 /))) call abort
+ if (minval (g, mask = l).ne.6) call abort
+ if (any (minloc (g(::2), mask = l(::2)).ne.(/ 4 /))) call abort
+ if (minval (g(::2), mask = l(::2)).ne.6) call abort
+ if (any (minloc (h, dim = 1, mask = l2).ne.(/ 1, 1, 1, 1, 5, 5, 6, 1, 1, 1 /))) call abort
+ if (any (minval (h, dim = 1, mask = l2).ne.(/ 7, 7, 7, 7, 6, 5, 4, 7, 7, 7 /))) call abort
+ if (any (minloc (h(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (h(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 7, 7, 6, 7, 7 /))) call abort
+ if (any (minloc (h, dim = 2, mask = l2).ne.(/ 1, 1, 1, 1, 6, 7, 1, 1, 1, 1 /))) call abort
+ if (any (minval (h, dim = 2, mask = l2).ne.(/ 7, 7, 7, 7, 5, 4, 7, 7, 7, 7 /))) call abort
+ if (any (minloc (h(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 1, 1, 3, 1, 1 /))) call abort
+ if (any (minval (h(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 7, 7, 6, 7, 7 /))) call abort
+ if (any (minloc (h, mask = l2).ne.(/ 6, 7 /))) call abort
+ if (minval (h, mask = l2).ne.4) call abort
+ if (any (minloc (h(::2,::2), mask = l2(::2,::2)).ne.(/ 3, 3 /))) call abort
+ if (minval (h(::2,::2), mask = l2(::2,::2)).ne.6) call abort
+ l = .false.
+ l2 = .false.
+ if (minloc (a, dim = 1, mask = l).ne.0) call abort
+ if (minval (a, dim = 1, mask = l).ne.m) call abort
+ if (minloc (a(::2), dim = 1, mask = l(::2)).ne.0) call abort
+ if (minval (a(::2), dim = 1, mask = l(::2)).ne.m) call abort
+ if (any (minloc (a, mask = l).ne.(/ 0 /))) call abort
+ if (minval (a, mask = l).ne.m) call abort
+ if (any (minloc (a(::2), mask = l(::2)).ne.(/ 0 /))) call abort
+ if (minval (a(::2), mask = l(::2)).ne.m) call abort
+ if (any (minloc (b, dim = 1, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (b, dim = 1, mask = l2).ne.(/ m, m, m, m, m, m, m, m, m, m /))) call abort
+ if (any (minloc (b(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (b(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ m, m, m, m, m /))) call abort
+ if (any (minloc (b, dim = 2, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (b, dim = 2, mask = l2).ne.(/ m, m, m, m, m, m, m, m, m, m /))) call abort
+ if (any (minloc (b(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (b(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ m, m, m, m, m /))) call abort
+ if (any (minloc (b, mask = l2).ne.(/ 0, 0 /))) call abort
+ if (minval (b, mask = l2).ne.m) call abort
+ if (any (minloc (b(::2,::2), mask = l2(::2,::2)).ne.(/ 0, 0 /))) call abort
+ if (minval (b(::2,::2), mask = l2(::2,::2)).ne.m) call abort
+ if (minloc (c, dim = 1, mask = l).ne.0) call abort
+ if (minval (c, dim = 1, mask = l).ne.m) call abort
+ if (minloc (c(::2), dim = 1, mask = l(::2)).ne.0) call abort
+ if (minval (c(::2), dim = 1, mask = l(::2)).ne.m) call abort
+ if (any (minloc (c, mask = l).ne.(/ 0 /))) call abort
+ if (minval (c, mask = l).ne.m) call abort
+ if (any (minloc (c(::2), mask = l(::2)).ne.(/ 0 /))) call abort
+ if (minval (c(::2), mask = l(::2)).ne.m) call abort
+ if (any (minloc (d, dim = 1, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (d, dim = 1, mask = l2).ne.(/ m, m, m, m, m, m, m, m, m, m /))) call abort
+ if (any (minloc (d(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (d(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ m, m, m, m, m /))) call abort
+ if (any (minloc (d, dim = 2, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (d, dim = 2, mask = l2).ne.(/ m, m, m, m, m, m, m, m, m, m /))) call abort
+ if (any (minloc (d(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (d(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ m, m, m, m, m /))) call abort
+ if (any (minloc (d, mask = l2).ne.(/ 0, 0 /))) call abort
+ if (minval (d, mask = l2).ne.m) call abort
+ if (any (minloc (d(::2,::2), mask = l2(::2,::2)).ne.(/ 0, 0 /))) call abort
+ if (minval (d(::2,::2), mask = l2(::2,::2)).ne.m) call abort
+ if (minloc (e, dim = 1, mask = l).ne.0) call abort
+ if (minval (e, dim = 1, mask = l).ne.n) call abort
+ if (minloc (e(::2), dim = 1, mask = l(::2)).ne.0) call abort
+ if (minval (e(::2), dim = 1, mask = l(::2)).ne.n) call abort
+ if (any (minloc (e, mask = l).ne.(/ 0 /))) call abort
+ if (minval (e, mask = l).ne.n) call abort
+ if (any (minloc (e(::2), mask = l(::2)).ne.(/ 0 /))) call abort
+ if (minval (e(::2), mask = l(::2)).ne.n) call abort
+ if (any (minloc (f, dim = 1, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (f, dim = 1, mask = l2).ne.(/ n, n, n, n, n, n, n, n, n, n /))) call abort
+ if (any (minloc (f(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (f(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ n, n, n, n, n /))) call abort
+ if (any (minloc (f, dim = 2, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (f, dim = 2, mask = l2).ne.(/ n, n, n, n, n, n, n, n, n, n /))) call abort
+ if (any (minloc (f(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (f(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ n, n, n, n, n /))) call abort
+ if (any (minloc (f, mask = l2).ne.(/ 0, 0 /))) call abort
+ if (minval (f, mask = l2).ne.n) call abort
+ if (any (minloc (f(::2,::2), mask = l2(::2,::2)).ne.(/ 0, 0 /))) call abort
+ if (minval (f(::2,::2), mask = l2(::2,::2)).ne.n) call abort
+ if (minloc (g, dim = 1, mask = l).ne.0) call abort
+ if (minval (g, dim = 1, mask = l).ne.n) call abort
+ if (minloc (g(::2), dim = 1, mask = l(::2)).ne.0) call abort
+ if (minval (g(::2), dim = 1, mask = l(::2)).ne.n) call abort
+ if (any (minloc (g, mask = l).ne.(/ 0 /))) call abort
+ if (minval (g, mask = l).ne.n) call abort
+ if (any (minloc (g(::2), mask = l(::2)).ne.(/ 0 /))) call abort
+ if (minval (g(::2), mask = l(::2)).ne.n) call abort
+ if (any (minloc (h, dim = 1, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (h, dim = 1, mask = l2).ne.(/ n, n, n, n, n, n, n, n, n, n /))) call abort
+ if (any (minloc (h(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (h(::2,::2), dim = 1, mask = l2(::2,::2)).ne.(/ n, n, n, n, n /))) call abort
+ if (any (minloc (h, dim = 2, mask = l2).ne.(/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (h, dim = 2, mask = l2).ne.(/ n, n, n, n, n, n, n, n, n, n /))) call abort
+ if (any (minloc (h(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ 0, 0, 0, 0, 0 /))) call abort
+ if (any (minval (h(::2,::2), dim = 2, mask = l2(::2,::2)).ne.(/ n, n, n, n, n /))) call abort
+ if (any (minloc (h, mask = l2).ne.(/ 0, 0 /))) call abort
+ if (minval (h, mask = l2).ne.n) call abort
+ if (any (minloc (h(::2,::2), mask = l2(::2,::2)).ne.(/ 0, 0 /))) call abort
+ if (minval (h(::2,::2), mask = l2(::2,::2)).ne.n) call abort
+ a = 7.0
+ b = 7.0
+ c = 7.0
+ d = 7.0
+end
--- gcc/testsuite/gfortran.dg/minlocval_4.f90.jj 2009-07-22 18:03:08.000000000 +0200
+++ gcc/testsuite/gfortran.dg/minlocval_4.f90 2009-07-22 19:28:18.000000000 +0200
@@ -0,0 +1,118 @@
+! { dg-do run }
+ real :: a(3,3), b(3), nan, minf, pinf, h
+ logical :: l, l2
+ logical :: l3(3,3), l4(3,3), l5(3,3)
+
+ nan = 0.0
+ minf = 0.0
+ pinf = 0.0
+ nan = 0.0/nan
+ minf = -1.0/minf
+ pinf = 1.0/pinf
+ h = huge(h)
+ l = .false.
+ l2 = .true.
+ l3 = .false.
+ l4 = .true.
+ l5 = .true.
+ l5(1,1) = .false.
+ l5(1,2) = .false.
+ l5(2,3) = .false.
+ a = reshape ((/ nan, nan, nan, pinf, pinf, pinf, pinf, minf, pinf /), (/ 3, 3 /))
+ if (minval (a).ne.minf) call abort
+ if (any (minloc (a).ne.(/ 2, 3 /))) call abort
+ b = minval (a, dim = 1)
+ if (.not.isnan(b(1))) call abort
+ b(1) = 0.0
+ if (any (b.ne.(/ 0.0, pinf, minf /))) call abort
+ if (any (minloc (a, dim = 1).ne.(/ 1, 1, 2 /))) call abort
+ b = minval (a, dim = 2)
+ if (any (b.ne.(/ pinf, minf, pinf /))) call abort
+ if (any (minloc (a, dim = 2).ne.(/ 2, 3, 2 /))) call abort
+ if (minval (a, mask = l).ne.h) call abort
+ if (any (minloc (a, mask = l).ne.(/ 0, 0 /))) call abort
+ b = minval (a, dim = 1, mask = l)
+ if (any (b.ne.(/ h, h, h /))) call abort
+ if (any (minloc (a, dim = 1, mask = l).ne.(/ 0, 0, 0 /))) call abort
+ b = minval (a, dim = 2, mask = l)
+ if (any (b.ne.(/ h, h, h /))) call abort
+ if (any (minloc (a, dim = 2, mask = l).ne.(/ 0, 0, 0 /))) call abort
+ if (minval (a, mask = l3).ne.h) call abort
+ if (any (minloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
+ b = minval (a, dim = 1, mask = l3)
+ if (any (b.ne.(/ h, h, h /))) call abort
+ if (any (minloc (a, dim = 1, mask = l3).ne.(/ 0, 0, 0 /))) call abort
+ b = minval (a, dim = 2, mask = l3)
+ if (any (b.ne.(/ h, h, h /))) call abort
+ if (any (minloc (a, dim = 2, mask = l3).ne.(/ 0, 0, 0 /))) call abort
+ if (minval (a, mask = l2).ne.minf) call abort
+ if (minval (a, mask = l4).ne.minf) call abort
+ if (any (minloc (a, mask = l2).ne.(/ 2, 3 /))) call abort
+ if (any (minloc (a, mask = l4).ne.(/ 2, 3 /))) call abort
+ b = minval (a, dim = 1, mask = l2)
+ if (.not.isnan(b(1))) call abort
+ b(1) = 0.0
+ if (any (b.ne.(/ 0.0, pinf, minf /))) call abort
+ if (any (minloc (a, dim = 1, mask = l2).ne.(/ 1, 1, 2 /))) call abort
+ b = minval (a, dim = 2, mask = l2)
+ if (any (b.ne.(/ pinf, minf, pinf /))) call abort
+ if (any (minloc (a, dim = 2, mask = l2).ne.(/ 2, 3, 2 /))) call abort
+ b = minval (a, dim = 1, mask = l4)
+ if (.not.isnan(b(1))) call abort
+ b(1) = 0.0
+ if (any (b.ne.(/ 0.0, pinf, minf /))) call abort
+ if (any (minloc (a, dim = 1, mask = l2).ne.(/ 1, 1, 2 /))) call abort
+ b = minval (a, dim = 2, mask = l4)
+ if (any (b.ne.(/ pinf, minf, pinf /))) call abort
+ if (any (minloc (a, dim = 2, mask = l2).ne.(/ 2, 3, 2 /))) call abort
+ if (minval (a, mask = l5).ne.pinf) call abort
+ if (any (minloc (a, mask = l5).ne.(/ 2, 2 /))) call abort
+ b = minval (a, dim = 1, mask = l5)
+ if (.not.isnan(b(1))) call abort
+ b(1) = 0.0
+ if (any (b.ne.(/ 0.0, pinf, pinf /))) call abort
+ if (any (minloc (a, dim = 1, mask = l5).ne.(/ 2, 2, 1 /))) call abort
+ b = minval (a, dim = 2, mask = l5)
+ if (any (b.ne.(/ pinf, pinf, pinf /))) call abort
+ if (any (minloc (a, dim = 2, mask = l5).ne.(/ 3, 2, 2 /))) call abort
+ a = nan
+ if (.not.isnan(minval (a))) call abort
+ if (minval (a, mask = l).ne.h) call abort
+ if (.not.isnan(minval (a, mask = l2))) call abort
+ if (minval (a, mask = l3).ne.h) call abort
+ if (.not.isnan(minval (a, mask = l4))) call abort
+ if (.not.isnan(minval (a, mask = l5))) call abort
+ if (any (minloc (a).ne.(/ 1, 1 /))) call abort
+ if (any (minloc (a, mask = l).ne.(/ 0, 0 /))) call abort
+ if (any (minloc (a, mask = l2).ne.(/ 1, 1 /))) call abort
+ if (any (minloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
+ if (any (minloc (a, mask = l4).ne.(/ 1, 1 /))) call abort
+ if (any (minloc (a, mask = l5).ne.(/ 2, 1 /))) call abort
+ a = pinf
+ if (minval (a).ne.pinf) call abort
+ if (minval (a, mask = l).ne.h) call abort
+ if (minval (a, mask = l2).ne.pinf) call abort
+ if (minval (a, mask = l3).ne.h) call abort
+ if (minval (a, mask = l4).ne.pinf) call abort
+ if (minval (a, mask = l5).ne.pinf) call abort
+ if (any (minloc (a).ne.(/ 1, 1 /))) call abort
+ if (any (minloc (a, mask = l).ne.(/ 0, 0 /))) call abort
+ if (any (minloc (a, mask = l2).ne.(/ 1, 1 /))) call abort
+ if (any (minloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
+ if (any (minloc (a, mask = l4).ne.(/ 1, 1 /))) call abort
+ if (any (minloc (a, mask = l5).ne.(/ 2, 1 /))) call abort
+ a = nan
+ a(1,3) = pinf
+ if (minval (a).ne.pinf) call abort
+ if (minval (a, mask = l).ne.h) call abort
+ if (minval (a, mask = l2).ne.pinf) call abort
+ if (minval (a, mask = l3).ne.h) call abort
+ if (minval (a, mask = l4).ne.pinf) call abort
+ if (minval (a, mask = l5).ne.pinf) call abort
+ if (any (minloc (a).ne.(/ 1, 3 /))) call abort
+ if (any (minloc (a, mask = l).ne.(/ 0, 0 /))) call abort
+ if (any (minloc (a, mask = l2).ne.(/ 1, 3 /))) call abort
+ if (any (minloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
+ if (any (minloc (a, mask = l4).ne.(/ 1, 3 /))) call abort
+ if (any (minloc (a, mask = l5).ne.(/ 1, 3 /))) call abort
+end
Jakub
Attachment:
Y353_.bz2
Description: BZip2 compressed data
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |