diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 13 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 22 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 179 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 6 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/optional_absent_4.f90 | 96 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/optional_absent_5.f90 | 144 |
6 files changed, 421 insertions, 39 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 30a7c0f..0446365 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2018-12-31 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/82995 + * trans-expr.c (gfc_conv_procedure_call): Pass NULL pointer + for missing optional dummy arguments for library routines. + * trans-intinsic.c (conv_mask_condition): New function. + (gfc_conv_intrinsic_arith): Detect and handle optional mask. + (gfc_conv_intrinsic_minmaxloc): Likewise. + (gfc_conv_intrinsic_findloc): Likewise. + (gfc_conv_intrinsic_minmaxval): Likewise. + (gfc_inline_intrinsic_function_p): Do not inline for rank > 1 if + an optional mask is present. + 2018-12-29 Steven G. Kargl <kargl@gcc.gnu.org> * expr.c (external_spec_function): Add ieee_support_subnormal to list diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index a2fd53c..d0a24fb 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5760,17 +5760,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, array-descriptor actual to array-descriptor dummy, see PR 41911 for why a check has to be inserted. fsym == NULL is checked as intrinsics required the descriptor - but do not always set fsym. */ + but do not always set fsym. + Also, it is necessary to pass a NULL pointer to library routines + which usually ignore optional arguments, so they can handle + these themselves. */ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional - && ((e->rank != 0 && elemental_proc) - || e->representation.length || e->ts.type == BT_CHARACTER - || (e->rank != 0 - && (fsym == NULL - || (fsym-> as - && (fsym->as->type == AS_ASSUMED_SHAPE - || fsym->as->type == AS_ASSUMED_RANK - || fsym->as->type == AS_DEFERRED)))))) + && (((e->rank != 0 && elemental_proc) + || e->representation.length || e->ts.type == BT_CHARACTER + || (e->rank != 0 + && (fsym == NULL + || (fsym->as + && (fsym->as->type == AS_ASSUMED_SHAPE + || fsym->as->type == AS_ASSUMED_RANK + || fsym->as->type == AS_DEFERRED))))) + || se->ignore_optional)) gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts, e->representation.length); } diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 40a7491..473334e 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -4359,6 +4359,28 @@ enter_nested_loop (gfc_se *se) return se->ss->loop; } +/* Build the condition for a mask, which may be optional. */ + +static tree +conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr, + bool optional_mask) +{ + tree present; + tree type; + + if (optional_mask) + { + type = TREE_TYPE (maskse->expr); + present = gfc_conv_expr_present (maskexpr->symtree->n.sym); + present = convert (type, present); + present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type, + present); + return fold_build2_loc (input_location, TRUTH_ORIF_EXPR, + type, present, maskse->expr); + } + else + return maskse->expr; +} /* Inline implementation of the sum and product intrinsics. */ static void @@ -4380,6 +4402,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, gfc_se *parent_se; gfc_expr *arrayexpr; gfc_expr *maskexpr; + bool optional_mask; if (expr->rank > 0) { @@ -4419,13 +4442,19 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, arrayexpr = arg_array->expr; if (op == NE_EXPR || norm2) - /* PARITY and NORM2. */ - maskexpr = NULL; + { + /* PARITY and NORM2. */ + maskexpr = NULL; + optional_mask = false; + } else { arg_mask = arg_array->next->next; gcc_assert (arg_mask != NULL); maskexpr = arg_mask->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; } if (expr->rank == 0) @@ -4444,17 +4473,22 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, arrayss); + + /* We add the mask first because the number of iterations is + taken from the last ss, and this breaks if an absent + optional argument is used for mask. */ + if (maskexpr && maskexpr->rank > 0) gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); gfc_conv_loop_setup (&loop, &expr->where); - gfc_mark_ss_chain_used (arrayss, 1); if (maskexpr && maskexpr->rank > 0) gfc_mark_ss_chain_used (maskss, 1); + gfc_mark_ss_chain_used (arrayss, 1); ploop = &loop; } @@ -4563,10 +4597,13 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, if (maskexpr && maskexpr->rank > 0) { - /* We enclose the above in if (mask) {...} . */ - + /* We enclose the above in if (mask) {...} . If the mask is an + optional argument, generate + IF (.NOT. PRESENT(MASK) .OR. MASK(I)). */ + tree ifmask; tmp = gfc_finish_block (&block); - tmp = build3_v (COND_EXPR, maskse.expr, tmp, + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, build_empty_stmt (input_location)); } else @@ -4591,10 +4628,13 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, } else { + tree ifmask; + gcc_assert (expr->rank == 0); gfc_init_se (&maskse, NULL); gfc_conv_expr_val (&maskse, maskexpr); - tmp = build3_v (COND_EXPR, maskse.expr, tmp, + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, build_empty_stmt (input_location)); } @@ -4833,6 +4873,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_se backse; tree pos; int n; + bool optional_mask; actual = expr->value.function.actual; @@ -4887,6 +4928,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) actual = actual->next->next; gcc_assert (actual); maskexpr = actual->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; backexpr = actual->next->next->expr; nonempty = NULL; if (maskexpr && maskexpr->rank != 0) @@ -4939,10 +4983,16 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, arrayss); + + /* We add the mask first because the number of iterations is taken + from the last ss, and this breaks if an absent optional argument + is used for mask. */ + if (maskss) gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); + /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); @@ -5103,10 +5153,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (maskss) { - /* We enclose the above in if (mask) {...}. */ - tmp = gfc_finish_block (&block); + /* We enclose the above in if (mask) {...}. If the mask is an + optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)). */ - tmp = build3_v (COND_EXPR, maskse.expr, tmp, + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = gfc_finish_block (&block); + tmp = build3_v (COND_EXPR, ifmask, tmp, build_empty_stmt (input_location)); } else @@ -5197,10 +5251,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (maskss) { - /* We enclose the above in if (mask) {...}. */ - tmp = gfc_finish_block (&block); + /* We enclose the above in if (mask) {...}. If the mask is + an optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)).*/ - tmp = build3_v (COND_EXPR, maskse.expr, tmp, + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = gfc_finish_block (&block); + tmp = build3_v (COND_EXPR, ifmask, tmp, build_empty_stmt (input_location)); } else @@ -5219,6 +5277,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskss == NULL) { + tree ifmask; + gfc_init_se (&maskse, NULL); gfc_conv_expr_val (&maskse, maskexpr); gfc_init_block (&block); @@ -5232,8 +5292,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_init_block (&elseblock); gfc_add_modify (&elseblock, pos, gfc_index_zero_node); elsetmp = gfc_finish_block (&elseblock); - - tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp); + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&se->pre, &block); } @@ -5276,6 +5336,7 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) gfc_expr *maskexpr; tree offset; int i; + bool optional_mask; array_arg = expr->value.function.actual; value_arg = array_arg->next; @@ -5326,6 +5387,9 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) offset = gfc_create_var (gfc_array_index_type, "offset"); maskexpr = mask_arg->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; /* Generate two loops, one for BACK=.true. and one for BACK=.false. */ @@ -5347,9 +5411,14 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) gfc_init_loopinfo (&loop); exit_label = gfc_build_label_decl (NULL_TREE); TREE_USED (exit_label) = 1; - gfc_add_ss_to_loop (&loop, arrayss); + + /* We add the mask first because the number of iterations is + taken from the last ss, and this breaks if an absent + optional argument is used for mask. */ + if (maskss) gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); @@ -5412,8 +5481,16 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location)); if (maskss) - tmp = build3_v (COND_EXPR, maskse.expr, tmp, - build_empty_stmt (input_location)); + { + /* We enclose the above in if (mask) {...}. If the mask is + an optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)). */ + + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } gfc_add_expr_to_block (&body, tmp); gfc_add_block_to_block (&body, &arrayse.post); @@ -5444,12 +5521,15 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr) /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskss == NULL) { + tree ifmask; tree if_stmt; + gfc_init_se (&maskse, NULL); gfc_conv_expr_val (&maskse, maskexpr); gfc_init_block (&block); gfc_add_expr_to_block (&block, maskse.expr); - if_stmt = build3_v (COND_EXPR, maskse.expr, tmp, + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + if_stmt = build3_v (COND_EXPR, ifmask, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, if_stmt); tmp = gfc_finish_block (&block); @@ -5576,6 +5656,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_expr *arrayexpr; gfc_expr *maskexpr; int n; + bool optional_mask; if (se->ss) { @@ -5665,6 +5746,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) actual = actual->next->next; gcc_assert (actual); maskexpr = actual->expr; + optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional; nonempty = NULL; if (maskexpr && maskexpr->rank != 0) { @@ -5687,9 +5771,14 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); - gfc_add_ss_to_loop (&loop, arrayss); + + /* We add the mask first because the number of iterations is taken + from the last ss, and this breaks if an absent optional argument + is used for mask. */ + if (maskss) gfc_add_ss_to_loop (&loop, maskss); + gfc_add_ss_to_loop (&loop, arrayss); /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); @@ -5832,9 +5921,15 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) 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)); + { + /* We enclose the above in if (mask) {...}. If the mask is an + optional argument, generate IF (.NOT. PRESENT(MASK) + .OR. MASK(I)). */ + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, + build_empty_stmt (input_location)); + } gfc_add_expr_to_block (&body, tmp); if (lab) @@ -5891,8 +5986,13 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) 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)); + { + tree ifmask; + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, 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. */ @@ -5920,6 +6020,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (maskexpr && maskss == NULL) { tree else_stmt; + tree ifmask; gfc_init_se (&maskse, NULL); gfc_conv_expr_val (&maskse, maskexpr); @@ -5932,7 +6033,9 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) 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); + + ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask); + tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&se->pre, &block); } @@ -10177,7 +10280,8 @@ gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) bool gfc_inline_intrinsic_function_p (gfc_expr *expr) { - gfc_actual_arglist *args; + gfc_actual_arglist *args, *dim_arg, *mask_arg; + gfc_expr *maskexpr; if (!expr->value.function.isym) return false; @@ -10191,10 +10295,25 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) return false; args = expr->value.function.actual; + dim_arg = args->next; + /* We need to be able to subset the SUM argument at compile-time. */ - if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT) + if (dim_arg->expr && dim_arg->expr->expr_type != EXPR_CONSTANT) return false; + /* FIXME: If MASK is optional for a more than two-dimensional + argument, the scalarizer gets confused if the mask is + absent. See PR 82995. For now, fall back to the library + function. */ + + mask_arg = dim_arg->next; + maskexpr = mask_arg->expr; + + if (expr->rank > 0 && maskexpr && maskexpr->expr_type == EXPR_VARIABLE + && maskexpr->symtree->n.sym->attr.dummy + && maskexpr->symtree->n.sym->attr.optional) + return false; + return true; case GFC_ISYM_TRANSPOSE: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 273ea11..c5ca8d9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2018-12-31 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/82995 + * gfortran.dg/optional_absent_4.f90: New test. + * gfortran.dg/optional_absent_5.f90: New test. + 2018-12-31 Martin Liska <mliska@suse.cz> * g++.dg/tree-prof/devirt.C: Fix scan pattern and test options. diff --git a/gcc/testsuite/gfortran.dg/optional_absent_4.f90 b/gcc/testsuite/gfortran.dg/optional_absent_4.f90 new file mode 100644 index 0000000..76470bd --- /dev/null +++ b/gcc/testsuite/gfortran.dg/optional_absent_4.f90 @@ -0,0 +1,96 @@ +! { dg-do run } +! PR 82995 - segfault passing on an optional argument; +! this tests the inline versions. +module y + implicit none +contains + + function sum_1 (input, mask) + logical, intent(in), optional :: mask(:) + integer, intent(in) :: input(:) + integer :: sum_1 + sum_1 = sum (input, mask) + end function sum_1 + + function sum_2 (input, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:) + integer :: sum_2 + sum_2 = sum(input, mask) + end function sum_2 + + function sum_3 (input, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer :: sum_3 + sum_3 = sum (input, mask) + end function sum_3 + + function minval_1 (input, mask) + logical, intent(in), optional :: mask(:,:) + real, intent(in) :: input(:,:) + real :: minval_1 + minval_1 = minval (input, mask) + end function minval_1 + + function maxval_1 (input, mask) + logical, intent(in), optional :: mask + real, intent(in) :: input(:,:) + real :: maxval_1 + maxval_1 = maxval (input, mask) + end function maxval_1 + + function maxloc_1 (input, mask) + logical, intent(in), optional :: mask(:) + real, intent(in) :: input(:) + integer :: maxloc_1 + + maxloc_1 = maxloc(input, dim=1, mask=mask) + end function maxloc_1 + + function findloc_1 (input, val, mask) + logical, intent(in), optional :: mask (:) + integer, intent(in) :: input(:) + integer, intent(in) :: val + integer :: findloc_1 + + findloc_1 = findloc(input, val, dim=1, mask=mask) + end function findloc_1 + + function findloc_2 (input, val, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:) + integer, intent(in) :: val + integer :: findloc_2 + + findloc_2 = findloc(input, val, dim=1, mask=mask) + end function findloc_2 + +end module y + +program test_sum_1 + use y + implicit none + integer :: input(5) = [1,2,4,8,16] + integer :: i2(2,3) = reshape([1,2,4,8,16,32], [2,3]) + real :: r2(2,3) = reshape ([32.,16.,8.,4.,2.,1.], [2,3]) + real :: r1(6) = [2.,4.,8.,32.,1.,16.] + integer :: res + real :: rres + res = sum_1(input) + if (res /= 31) stop 1 + res = sum_2 (input) + if (res /= 31) stop 2 + res = sum_3 (i2) + if (res /= 63) stop 3 + rres = minval_1 (r2) + if (rres /= 1.0) stop 4 + rres = maxval_1 (r2) + if (rres /= 32.) stop 5 + res = maxloc_1 (r1) + if (res /= 4) stop 6 + res = findloc_1 (input, 8) + if (res /= 4) stop 7 + res = findloc_2 (input, 2) + if (res /= 2) stop 8 +end program test_sum_1 diff --git a/gcc/testsuite/gfortran.dg/optional_absent_5.f90 b/gcc/testsuite/gfortran.dg/optional_absent_5.f90 new file mode 100644 index 0000000..42f1a91 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/optional_absent_5.f90 @@ -0,0 +1,144 @@ +! { dg-do run } +! PR 82995 - segfault passing on an optional argument; +! this tests the library versions. +module z + implicit none +contains + subroutine sum_1 (input, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = sum (input, dim=1, mask=mask) + end subroutine sum_1 + + subroutine sum_2 (input, res, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = sum (input, dim=1, mask=mask) + end subroutine sum_2 + + subroutine maxloc_1 (input, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = maxloc (input, dim=1, mask=mask) + end subroutine maxloc_1 + + subroutine minloc_1 (input, res, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = minloc (input, dim=1, mask=mask) + end subroutine minloc_1 + + subroutine maxloc_2 (input, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer :: n + n = 1 + res = maxloc (input, dim=n, mask=mask) + end subroutine maxloc_2 + + subroutine findloc_1 (input, val, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer, intent(in) :: val + res = findloc(input, val) + end subroutine findloc_1 + + subroutine findloc_2 (input, val, res, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer, intent(in) :: val + res = findloc(input, val) + end subroutine findloc_2 + + subroutine findloc_3 (input, val, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer, intent(in) :: val + res = findloc(input, val, dim=1) + end subroutine findloc_3 + + subroutine findloc_4 (input, val, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer, intent(in) :: val + integer :: n = 1 + res = findloc(input, val, dim=n) + end subroutine findloc_4 + + subroutine maxval_1 (input, res, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = maxval (input, dim=1, mask=mask) + end subroutine maxval_1 + + subroutine maxval_2 (input, res, mask) + logical, intent(in), optional :: mask + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer :: n = 1 + res = maxval (input, dim=n, mask=mask) + end subroutine maxval_2 + + subroutine minval_1 (input, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + res = minval (input, dim=1, mask=mask) + end subroutine minval_1 + + subroutine minval_2 (input, res, mask) + logical, intent(in), optional :: mask(:,:) + integer, intent(in) :: input(:,:) + integer, dimension(:), intent(out) :: res + integer :: n = 1 + res = minval (input, dim=n, mask=mask) + end subroutine minval_2 + +end module z + +program main + use z + implicit none + integer :: i2(2,3) = reshape([1,2,4,8,16,32], [2,3]) + integer, dimension(3) :: res3 + integer, dimension(2) :: res2 + call sum_1 (i2, res3) + if (any (res3 /= [3, 12, 48])) stop 1 + res3 = -2 + call sum_2 (i2, res3) + if (any (res3 /= [3, 12, 48])) stop 2 + call maxloc_1 (i2, res3) + if (any (res3 /= 2)) stop 3 + call minloc_1 (i2, res3) + if (any (res3 /= 1)) stop 4 + call maxloc_2 (i2, res3) + if (any (res3 /= 2)) stop 5 + call findloc_1 (i2, 4, res2) + if (any(res2 /= [1,2])) stop 6 + res2 = -1234 + call findloc_2 (i2, 4, res2) + if (any(res2 /= [1,2])) stop 7 + call findloc_3 (i2, 4, res3) + if (any(res3 /= [0,1,0])) stop 8 + call findloc_4 (i2, 4, res3) + if (any(res3 /= [0,1,0])) stop 9 + call maxval_1 (i2, res3) + if (any (res3 /= [2,8,32])) stop 10 + call minval_1 (i2, res3) + if (any (res3 /= [1,4,16])) stop 11 + call maxval_2 (i2, res3) + if (any (res3 /= [2,8,32])) stop 12 + call minval_2 (i2, res3) + if (any (res3 /= [1,4,16])) stop 13 + +end program main |