diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/trans-intrinsic.cc | 96 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/minmaxloc_21.f90 | 572 |
2 files changed, 625 insertions, 43 deletions
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 4011b9e..12bda21 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5478,6 +5478,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_actual_arglist *back_arg; gfc_ss *arrayss = nullptr; gfc_ss *maskss = nullptr; + gfc_ss *orig_ss = nullptr; gfc_se arrayse; gfc_se maskse; gfc_se nested_se; @@ -5712,6 +5713,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (nested_loop) { ploop = enter_nested_loop (&nested_se); + orig_ss = nested_se.ss; ploop->temp_dim = 1; } else @@ -5786,9 +5788,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) } else { - gcc_assert (!nested_loop); - for (int i = 0; i < loop.dimen; i++) - gfc_add_modify (&loop.pre, pos[i], gfc_index_zero_node); + for (int i = 0; i < ploop->dimen; i++) + gfc_add_modify (&ploop->pre, pos[i], gfc_index_zero_node); lab1 = gfc_build_label_decl (NULL_TREE); TREE_USED (lab1) = 1; lab2 = gfc_build_label_decl (NULL_TREE); @@ -5819,10 +5820,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* If we have a mask, only check this element if the mask is set. */ if (maskexpr && maskexpr->rank > 0) { - gcc_assert (!nested_loop); - gfc_init_se (&maskse, NULL); - gfc_copy_loopinfo_to_se (&maskse, &loop); - maskse.ss = maskss; + gfc_init_se (&maskse, base_se); + gfc_copy_loopinfo_to_se (&maskse, ploop); + if (!nested_loop) + maskse.ss = maskss; gfc_conv_expr_val (&maskse, maskexpr); gfc_add_block_to_block (&body, &maskse.pre); @@ -5850,13 +5851,11 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) stmtblock_t ifblock2; tree ifbody2; - gcc_assert (!nested_loop); - gfc_start_block (&ifblock2); - for (int i = 0; i < loop.dimen; i++) + for (int i = 0; i < ploop->dimen; i++) { tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]), - loop.loopvar[i], offset[i]); + ploop->loopvar[i], offset[i]); gfc_add_modify (&ifblock2, pos[i], tmp); } ifbody2 = gfc_finish_block (&ifblock2); @@ -5940,17 +5939,24 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (lab1) { - gcc_assert (!nested_loop); + for (int i = 0; i < ploop->dimen; i++) + ploop->from[i] = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (ploop->from[i]), + second_loop_entry, idx[i], + ploop->from[i]); - for (int i = 0; i < loop.dimen; i++) - loop.from[i] = fold_build3_loc (input_location, COND_EXPR, - TREE_TYPE (loop.from[i]), - second_loop_entry, idx[i], - loop.from[i]); + gfc_trans_scalarized_loop_boundary (ploop, &body); - gfc_trans_scalarized_loop_boundary (&loop, &body); + if (nested_loop) + { + /* The first loop already advanced the parent se'ss chain, so clear + the parent now to avoid doing it a second time, making the chain + out of sync. */ + nested_se.parent = nullptr; + nested_se.ss = orig_ss; + } - stmtblock_t * const outer_block = &loop.code[loop.dimen - 1]; + stmtblock_t * const outer_block = &ploop->code[ploop->dimen - 1]; if (HONOR_NANS (DECL_MODE (limit))) { @@ -5959,7 +5965,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) stmtblock_t init_block; gfc_init_block (&init_block); - for (int i = 0; i < loop.dimen; i++) + for (int i = 0; i < ploop->dimen; i++) gfc_add_modify (&init_block, pos[i], gfc_index_one_node); tree ifbody = gfc_finish_block (&init_block); @@ -5975,9 +5981,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* If we have a mask, only check this element if the mask is set. */ if (maskexpr && maskexpr->rank > 0) { - gfc_init_se (&maskse, NULL); - gfc_copy_loopinfo_to_se (&maskse, &loop); - maskse.ss = maskss; + gfc_init_se (&maskse, base_se); + gfc_copy_loopinfo_to_se (&maskse, ploop); + if (!nested_loop) + maskse.ss = maskss; gfc_conv_expr_val (&maskse, maskexpr); gfc_add_block_to_block (&body, &maskse.pre); @@ -5987,9 +5994,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) 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_init_se (&arrayse, base_se); + gfc_copy_loopinfo_to_se (&arrayse, ploop); + if (!nested_loop) + arrayse.ss = arrayss; gfc_conv_expr_val (&arrayse, arrayexpr); gfc_add_block_to_block (&block, &arrayse.pre); @@ -5999,10 +6007,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* Assign the value to the limit... */ gfc_add_modify (&ifblock, limit, arrayse.expr); - for (int i = 0; i < loop.dimen; i++) + for (int i = 0; i < ploop->dimen; i++) { tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]), - loop.loopvar[i], offset[i]); + ploop->loopvar[i], offset[i]); gfc_add_modify (&ifblock, pos[i], tmp); } @@ -6061,7 +6069,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_trans_scalarizing_loops (ploop, &body); if (lab2) - gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2)); + gfc_add_expr_to_block (&ploop->pre, build1_v (LABEL_EXPR, lab2)); /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskexpr->rank == 0) @@ -11871,6 +11879,18 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED) gfc_ss *tmp_ss = gfc_ss_terminator; + bool scalar_mask = false; + if (mask) + { + gfc_ss *mask_ss = gfc_walk_subexpr (tmp_ss, mask); + if (mask_ss == tmp_ss) + scalar_mask = true; + else if (maybe_absent_optional_variable (mask)) + mask_ss->info->can_be_null_ref = true; + + tmp_ss = mask_ss; + } + gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array); gcc_assert (array_ss != tmp_ss); @@ -11882,7 +11902,7 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr *expr ATTRIBUTE_UNUSED) gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1); tail->next = ss; - if (mask) + if (scalar_mask) { tmp_ss = gfc_get_scalar_ss (tmp_ss, mask); /* MASK can be a forwarded optional argument, so make the necessary setup @@ -12032,11 +12052,9 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) gfc_actual_arglist *array_arg = expr->value.function.actual; gfc_actual_arglist *dim_arg = array_arg->next; - gfc_actual_arglist *mask_arg = dim_arg->next; gfc_expr *array = array_arg->expr; gfc_expr *dim = dim_arg->expr; - gfc_expr *mask = mask_arg->expr; if (!(array->ts.type == BT_INTEGER || array->ts.type == BT_REAL)) @@ -12045,19 +12063,11 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr) if (array->rank == 1) return true; - if (dim == nullptr) - return true; - - if (dim->expr_type != EXPR_CONSTANT) + if (dim != nullptr + && dim->expr_type != EXPR_CONSTANT) return false; - if (array->ts.type != BT_INTEGER) - return false; - - if (mask == nullptr || mask->rank == 0) - return true; - - return false; + return true; } default: diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_21.f90 b/gcc/testsuite/gfortran.dg/minmaxloc_21.f90 new file mode 100644 index 0000000..f31335c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minmaxloc_21.f90 @@ -0,0 +1,572 @@ +! { dg-do compile } +! { dg-additional-options "-O -fdump-tree-original" } +! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?minloc" "original" } } +! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?maxloc" "original" } } +! +! PR fortran/90608 +! Check that all MINLOC and MAXLOC calls are inlined with optimizations, +! when DIM is a constant, and either ARRAY has REAL type or MASK is non-scalar. + +subroutine check_real_maxloc + implicit none + integer, parameter :: data60(*) = (/ 2, 5, 4, 6, 0, 9, 3, 5, 4, 4, & + 1, 7, 3, 2, 1, 2, 5, 4, 6, 0, & + 9, 3, 5, 4, 4, 1, 7, 3, 2, 1, & + 2, 5, 4, 6, 0, 9, 3, 5, 4, 4, & + 1, 7, 3, 2, 1, 2, 5, 4, 6, 0, & + 9, 3, 5, 4, 4, 1, 7, 3, 2, 1 /) + integer, parameter :: data1(*) = (/ 2, 3, 2, 3, & + 1, 2, 3, 2, & + 3, 1, 2, 3, & + 2, 3, 1, 2, & + 3, 2, 3, 1 /) + integer, parameter :: data2(*) = (/ 2, 1, 2, & + 3, 2, 3, & + 4, 3, 4, & + 2, 1, 2, & + 1, 2, 1 /) + integer, parameter :: data3(*) = (/ 5, 1, 5, & + 1, 2, 1, & + 2, 1, 2, & + 3, 2, 3 /) + call check_real_const_shape_rank_3 + call check_real_const_shape_empty_4 + call check_real_alloc_rank_3 + call check_real_alloc_empty_4 +contains + subroutine check_real_const_shape_rank_3() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + r = maxloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 1 + if (any(r /= reshape((/ real:: data1 /), (/ 4, 5 /)))) error stop 2 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 3 + if (any(r /= reshape((/ real:: data2 /), (/ 3, 5 /)))) error stop 4 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 5 + if (any(r /= reshape((/ real:: data3 /), (/ 3, 4 /)))) error stop 6 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ real:: /), shape(a)) + r = maxloc(a, dim=1) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 11 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 12 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 13 + if (any(r /= 0)) error stop 14 + r = maxloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 15 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + r = maxloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 21 + if (any(r /= reshape((/ real:: data1 /), shape=(/ 4, 5 /)))) error stop 22 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 23 + if (any(r /= reshape((/ real:: data2 /), shape=(/ 3, 5 /)))) error stop 24 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 25 + if (any(r /= reshape((/ real:: data3 /), shape=(/ 3, 4 /)))) error stop 26 + end subroutine + subroutine check_real_alloc_empty_4() + real, allocatable :: a(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ real:: /), shape(a)) + r = maxloc(a, dim=1) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 31 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 32 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 33 + if (any(r /= 0)) error stop 34 + r = maxloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 35 + end subroutine +end subroutine + +subroutine check_maxloc_with_mask + implicit none + integer, parameter :: data60(*) = (/ 2, 5, 4, 6, 0, 9, 3, 5, 4, 4, & + 1, 7, 3, 2, 1, 2, 5, 4, 6, 0, & + 9, 3, 5, 4, 4, 1, 7, 3, 2, 1, & + 2, 5, 4, 6, 0, 9, 3, 5, 4, 4, & + 1, 7, 3, 2, 1, 2, 5, 4, 6, 0, & + 9, 3, 5, 4, 4, 1, 7, 3, 2, 1 /) + logical, parameter :: mask60(*) = (/ .true. , .false., .false., .false., & + .true. , .false., .true. , .false., & + .false., .true. , .true. , .false., & + .true. , .true. , .true. , .true. , & + .false., .true. , .false., .true. , & + .false., .true. , .false., .true. , & + .true. , .false., .false., .true. , & + .true. , .true. , .true. , .false., & + .false., .false., .true. , .false., & + .true. , .false., .true. , .true. , & + .true. , .false., .true. , .true. , & + .false., .true. , .false., .true. , & + .false., .true. , .false., .false., & + .false., .true. , .true. , .true. , & + .false., .true. , .false., .true. /) + integer, parameter :: data1(*) = (/ 2, 3, 2, 3, & + 1, 2, 3, 2, & + 3, 1, 2, 3, & + 2, 3, 1, 2, & + 3, 2, 3, 1 /) + integer, parameter :: data2(*) = (/ 2, 1, 2, & + 3, 2, 3, & + 4, 3, 4, & + 2, 1, 2, & + 1, 2, 1 /) + integer, parameter :: data3(*) = (/ 5, 1, 5, & + 1, 2, 1, & + 2, 1, 2, & + 3, 2, 3 /) + integer, parameter :: data1m(*) = (/ 1, 2, 1, 1, & + 1, 3, 2, 3, & + 1, 1, 1, 2, & + 3, 1, 1, 3, & + 2, 3, 1, 1 /) + integer, parameter :: data2m(*) = (/ 4, 4, 0, & + 1, 1, 2, & + 1, 2, 2, & + 2, 3, 1, & + 3, 3, 2 /) + integer, parameter :: data3m(*) = (/ 3, 2, 4, & + 4, 3, 2, & + 5, 4, 0, & + 1, 1, 2 /) + call check_int_const_shape_rank_3 + call check_int_const_shape_empty_4 + call check_int_alloc_rank_3 + call check_int_alloc_empty_4 + call check_real_const_shape_rank_3 + call check_real_const_shape_empty_4 + call check_real_alloc_rank_3 + call check_real_alloc_empty_4 +contains + subroutine check_int_const_shape_rank_3() + integer :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + m = reshape(mask60, shape(m)) + r = maxloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 41 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 42 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 43 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 44 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 45 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 46 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + logical :: m(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m = reshape((/ logical:: /), shape(m)) + r = maxloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 51 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 52 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 53 + if (any(r /= 0)) error stop 54 + r = maxloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 55 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5), m(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + m(:,:,:) = reshape(mask60, shape(m)) + r = maxloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 61 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 62 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 63 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 64 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 65 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 66 + end subroutine + subroutine check_int_alloc_empty_4() + integer, allocatable :: a(:,:,:,:) + logical, allocatable :: m(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7), m(9,3,0,7)) + a(:,:,:,:) = reshape((/ integer:: /), shape(a)) + m(:,:,:,:) = reshape((/ logical:: /), shape(m)) + r = maxloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 71 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 72 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 73 + if (any(r /= 0)) error stop 74 + r = maxloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 75 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + m = reshape(mask60, shape(m)) + r = maxloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 81 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 82 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 83 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 84 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 85 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 86 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + logical :: m(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ real:: /), shape(a)) + m = reshape((/ logical:: /), shape(m)) + r = maxloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 91 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 92 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 93 + if (any(r /= 0)) error stop 94 + r = maxloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 95 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5), m(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + m(:,:,:) = reshape(mask60, shape(m)) + r = maxloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 101 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 102 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 103 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 104 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 105 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 106 + end subroutine + subroutine check_real_alloc_empty_4() + real, allocatable :: a(:,:,:,:) + logical, allocatable :: m(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7), m(9,3,0,7)) + a(:,:,:,:) = reshape((/ real:: /), shape(a)) + m(:,:,:,:) = reshape((/ logical :: /), shape(m)) + r = maxloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 111 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 112 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 113 + if (any(r /= 0)) error stop 114 + r = maxloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 115 + end subroutine +end subroutine + +subroutine check_real_minloc + implicit none + integer, parameter :: data60(*) = (/ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, & + 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, & + 0, 6, 4, 5, 5, 8, 2, 6, 7, 8, & + 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, & + 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, & + 0, 6, 4, 5, 5, 8, 2, 6, 7, 8 /) + integer, parameter :: data1(*) = (/ 2, 3, 2, 3, & + 1, 2, 3, 2, & + 3, 1, 2, 3, & + 2, 3, 1, 2, & + 3, 2, 3, 1 /) + integer, parameter :: data2(*) = (/ 2, 1, 2, & + 3, 2, 3, & + 4, 3, 4, & + 2, 1, 2, & + 1, 2, 1 /) + integer, parameter :: data3(*) = (/ 5, 1, 5, & + 1, 2, 1, & + 2, 1, 2, & + 3, 2, 3 /) + call check_real_const_shape_rank_3 + call check_real_const_shape_empty_4 + call check_real_alloc_rank_3 + call check_real_alloc_empty_4 +contains + subroutine check_real_const_shape_rank_3() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + r = minloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 141 + if (any(r /= reshape((/ real:: data1 /), (/ 4, 5 /)))) error stop 142 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 143 + if (any(r /= reshape((/ real:: data2 /), (/ 3, 5 /)))) error stop 144 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 145 + if (any(r /= reshape((/ real:: data3 /), (/ 3, 4 /)))) error stop 146 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ real:: /), shape(a)) + r = minloc(a, dim=1) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 151 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 152 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 153 + if (any(r /= 0)) error stop 154 + r = minloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 155 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + r = minloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 161 + if (any(r /= reshape((/ real:: data1 /), shape=(/ 4, 5 /)))) error stop 162 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 163 + if (any(r /= reshape((/ real:: data2 /), shape=(/ 3, 5 /)))) error stop 164 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 165 + if (any(r /= reshape((/ real:: data3 /), shape=(/ 3, 4 /)))) error stop 166 + end subroutine + subroutine check_real_alloc_empty_4() + real, allocatable :: a(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ real:: /), shape(a)) + r = minloc(a, dim=1) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 171 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 172 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 173 + if (any(r /= 0)) error stop 174 + r = minloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 175 + end subroutine +end subroutine + +subroutine check_minloc_with_mask + implicit none + integer, parameter :: data60(*) = (/ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, & + 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, & + 0, 6, 4, 5, 5, 8, 2, 6, 7, 8, & + 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, & + 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, & + 0, 6, 4, 5, 5, 8, 2, 6, 7, 8 /) + logical, parameter :: mask60(*) = (/ .true. , .false., .false., .false., & + .true. , .false., .true. , .false., & + .false., .true. , .true. , .false., & + .true. , .true. , .true. , .true. , & + .false., .true. , .false., .true. , & + .false., .true. , .false., .true. , & + .true. , .false., .false., .true. , & + .true. , .true. , .true. , .false., & + .false., .false., .true. , .false., & + .true. , .false., .true. , .true. , & + .true. , .false., .true. , .true. , & + .false., .true. , .false., .true. , & + .false., .true. , .false., .false., & + .false., .true. , .true. , .true. , & + .false., .true. , .false., .true. /) + integer, parameter :: data1(*) = (/ 2, 3, 2, 3, & + 1, 2, 3, 2, & + 3, 1, 2, 3, & + 2, 3, 1, 2, & + 3, 2, 3, 1 /) + integer, parameter :: data2(*) = (/ 2, 1, 2, & + 3, 2, 3, & + 4, 3, 4, & + 2, 1, 2, & + 1, 2, 1 /) + integer, parameter :: data3(*) = (/ 5, 1, 5, & + 1, 2, 1, & + 2, 1, 2, & + 3, 2, 3 /) + integer, parameter :: data1m(*) = (/ 1, 2, 1, 1, & + 1, 3, 2, 3, & + 1, 1, 1, 2, & + 3, 1, 1, 3, & + 2, 3, 1, 1 /) + integer, parameter :: data2m(*) = (/ 4, 4, 0, & + 1, 1, 2, & + 1, 2, 2, & + 2, 3, 1, & + 3, 3, 2 /) + integer, parameter :: data3m(*) = (/ 3, 2, 4, & + 4, 3, 2, & + 5, 4, 0, & + 1, 1, 2 /) + call check_int_const_shape_rank_3 + call check_int_const_shape_empty_4 + call check_int_alloc_rank_3 + call check_int_alloc_empty_4 + call check_real_const_shape_rank_3 + call check_real_const_shape_empty_4 + call check_real_alloc_rank_3 + call check_real_alloc_empty_4 + call check_lower_bounds + call check_dependencies +contains + subroutine check_int_const_shape_rank_3() + integer :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + m = reshape(mask60, shape(m)) + r = minloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 181 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 182 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 183 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 184 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 185 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 186 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + logical :: m(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + m = reshape((/ logical:: /), shape(m)) + r = minloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 191 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 192 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 193 + if (any(r /= 0)) error stop 194 + r = minloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 195 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5), m(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + m(:,:,:) = reshape(mask60, shape(m)) + r = minloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 201 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 202 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 203 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 204 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 205 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 206 + end subroutine + subroutine check_int_alloc_empty_4() + integer, allocatable :: a(:,:,:,:) + logical, allocatable :: m(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7), m(9,3,0,7)) + a(:,:,:,:) = reshape((/ integer:: /), shape(a)) + m(:,:,:,:) = reshape((/ logical:: /), shape(m)) + r = minloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 211 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 212 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 213 + if (any(r /= 0)) error stop 214 + r = minloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 215 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + m = reshape(mask60, shape(m)) + r = minloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 221 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 222 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 223 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 224 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 225 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 226 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + logical :: m(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ real:: /), shape(a)) + m = reshape((/ logical:: /), shape(m)) + r = minloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 231 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 232 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 233 + if (any(r /= 0)) error stop 234 + r = minloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 235 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5), m(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + m(:,:,:) = reshape(mask60, shape(m)) + r = minloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 241 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 242 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 243 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 244 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 245 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 246 + end subroutine + subroutine check_real_alloc_empty_4() + real, allocatable :: a(:,:,:,:) + logical, allocatable :: m(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7), m(9,3,0,7)) + a(:,:,:,:) = reshape((/ real:: /), shape(a)) + m(:,:,:,:) = reshape((/ logical :: /), shape(m)) + r = minloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 251 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 252 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 253 + if (any(r /= 0)) error stop 254 + r = minloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 255 + end subroutine +end subroutine |