[1/7] fortran: Add tests covering inline MINLOC/MAXLOC with DIM [PR90608]

Message ID	20241014150816.315478-2-morin-mikael@orange.fr
State	New
Headers	show Return-Path: <gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org> DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 281293857003 From: Mikael Morin <morin-mikael@orange.fr> To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH 1/7] fortran: Add tests covering inline MINLOC/MAXLOC with DIM [PR90608] Date: Mon, 14 Oct 2024 17:08:10 +0200 Message-ID: <20241014150816.315478-2-morin-mikael@orange.fr> In-Reply-To: <20241014150816.315478-1-morin-mikael@orange.fr> References: <20241014150816.315478-1-morin-mikael@orange.fr> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit Precedence: list Errors-To: gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org
Series	fortran: Inline MINLOC/MAXLOC with DIM [PR90608] \| expand [0/7] fortran: Inline MINLOC/MAXLOC with DIM [PR90608] [1/7] fortran: Add tests covering inline MINLOC/MAXLOC with DIM [PR90608] [2/7] fortran: Inline unmasked integral MINLOC/MAXLOC with DIM [PR90608] [3/7] fortran: Inline MINLOC/MAXLOC with DIM and scalar MASK [PR90608] [4/7] fortran: Check MASK directly instead of its scalarization chain [5/7] fortran: Inline non-character MINLOC/MAXLOC with DIM [PR90608] [6/7] fortran: Check for empty MINLOC/MAXLOC ARRAY along DIM only [7/7] fortran: Evaluate once BACK argument of MINLOC/MAXLOC with DIM [PR90608]

diff --git a/gcc/testsuite/gfortran.dg/ieee/maxloc_nan_2.f90 b/gcc/testsuite/gfortran.dg/ieee/maxloc_nan_2.f90 new file mode 100644 index 00000000000..4d9b8707362 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/maxloc_nan_2.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline maxloc implementation, +! when the dim argument is present. + +program p + implicit none + call check_without_mask + call check_with_mask +contains + subroutine check_without_mask() + use, intrinsic :: ieee_arithmetic + real, allocatable :: a(:,:,:) + real :: nan + integer, allocatable :: r(:,:) + if (.not. ieee_support_nan(nan)) return + nan = ieee_value(nan, ieee_quiet_nan) + allocate(a(3,4,5), source = nan) + r = maxloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 21 + if (any(r /= 1)) error stop 22 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 23 + if (any(r /= 1)) error stop 24 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 25 + if (any(r /= 1)) error stop 26 + end subroutine + subroutine check_with_mask() + use, intrinsic :: ieee_arithmetic + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + real :: nan + integer, allocatable :: r(:,:) + if (.not. ieee_support_nan(nan)) return + nan = ieee_value(nan, ieee_quiet_nan) + allocate(a(2,3,4), source = nan) + allocate(m(2,3,4)) + m(:,:,:) = reshape((/ .false., .false., .true. , .true. , & + .false., .true. , .false., .false., & + .false., .true. , .true. , .false., & + .true. , .true. , .true. , .false., & + .false., .true. , .true. , .false., & + .false., .true. , .false., .false. /), shape(m)) + r = maxloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 51 + if (any(r /= reshape((/ 0, 1, 2, & + 0, 2, 1, & + 1, 1, 2, & + 1, 2, 0 /), (/ 3, 4 /)))) error stop 52 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 2, 4 /))) error stop 53 + if (any(r /= reshape((/ 2, 2, & + 3, 2, & + 1, 1, & + 1, 2 /), (/ 2, 4 /)))) error stop 54 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 2, 3 /))) error stop 55 + if (any(r /= reshape((/ 3, 3, & + 1, 1, & + 2, 1 /), (/ 2, 3 /)))) error stop 56 + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/ieee/minloc_nan_2.f90 b/gcc/testsuite/gfortran.dg/ieee/minloc_nan_2.f90 new file mode 100644 index 00000000000..37c097a7acb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/minloc_nan_2.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline minloc implementation, +! when the dim argument is present. + +program p + implicit none + call check_without_mask + call check_with_mask +contains + subroutine check_without_mask() + use, intrinsic :: ieee_arithmetic + real, allocatable :: a(:,:,:) + real :: nan + integer, allocatable :: r(:,:) + if (.not. ieee_support_nan(nan)) return + nan = ieee_value(nan, ieee_quiet_nan) + allocate(a(3,4,5), source = nan) + r = minloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 21 + if (any(r /= 1)) error stop 22 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 23 + if (any(r /= 1)) error stop 24 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 25 + if (any(r /= 1)) error stop 26 + end subroutine + subroutine check_with_mask() + use, intrinsic :: ieee_arithmetic + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + real :: nan + integer, allocatable :: r(:,:) + if (.not. ieee_support_nan(nan)) return + nan = ieee_value(nan, ieee_quiet_nan) + allocate(a(2,3,4), source = nan) + allocate(m(2,3,4)) + m(:,:,:) = reshape((/ .false., .false., .true. , .true. , & + .false., .true. , .false., .false., & + .false., .true. , .true. , .false., & + .true. , .true. , .true. , .false., & + .false., .true. , .true. , .false., & + .false., .true. , .false., .false. /), shape(m)) + r = minloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 51 + if (any(r /= reshape((/ 0, 1, 2, & + 0, 2, 1, & + 1, 1, 2, & + 1, 2, 0 /), (/ 3, 4 /)))) error stop 52 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 2, 4 /))) error stop 53 + if (any(r /= reshape((/ 2, 2, & + 3, 2, & + 1, 1, & + 1, 2 /), (/ 2, 4 /)))) error stop 54 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 2, 3 /))) error stop 55 + if (any(r /= reshape((/ 3, 3, & + 1, 1, & + 2, 1 /), (/ 2, 3 /)))) error stop 56 + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/maxloc_with_dim_1.f90 b/gcc/testsuite/gfortran.dg/maxloc_with_dim_1.f90 new file mode 100644 index 00000000000..a432a6164c7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/maxloc_with_dim_1.f90 @@ -0,0 +1,201 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline maxloc implementation, +! when the dim argument is present. + +program p + 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_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) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + r = maxloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 11 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 12 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 13 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 14 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 15 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 16 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + r = maxloc(a, dim=1) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 21 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 22 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 23 + if (any(r /= 0)) error stop 24 + r = maxloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 25 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + r = maxloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 31 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 32 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 33 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 34 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 35 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 36 + end subroutine + subroutine check_int_alloc_empty_4() + integer, allocatable :: a(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ integer:: /), shape(a)) + r = maxloc(a, dim=1) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 41 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 42 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 43 + if (any(r /= 0)) error stop 44 + r = maxloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 45 + end subroutine + 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 51 + if (any(r /= reshape((/ real:: data1 /), (/ 4, 5 /)))) error stop 52 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 53 + if (any(r /= reshape((/ real:: data2 /), (/ 3, 5 /)))) error stop 54 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 55 + if (any(r /= reshape((/ real:: data3 /), (/ 3, 4 /)))) error stop 56 + 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 61 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 62 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 63 + if (any(r /= 0)) error stop 64 + r = maxloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 65 + 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 71 + if (any(r /= reshape((/ real:: data1 /), shape=(/ 4, 5 /)))) error stop 72 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 73 + if (any(r /= reshape((/ real:: data2 /), shape=(/ 3, 5 /)))) error stop 74 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 75 + if (any(r /= reshape((/ real:: data3 /), shape=(/ 3, 4 /)))) error stop 76 + 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 81 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 82 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 83 + if (any(r /= 0)) error stop 84 + r = maxloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 85 + end subroutine + subroutine check_lower_bounds() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3:5,-1:2,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + r = maxloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 91 + if (any(lbound(r) /= 1)) error stop 92 + if (any(ubound(r) /= (/ 4, 5 /))) error stop 93 + r = maxloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 94 + if (any(lbound(r) /= 1)) error stop 95 + if (any(ubound(r) /= (/ 3, 5 /))) error stop 96 + r = maxloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 97 + if (any(lbound(r) /= 1)) error stop 98 + if (any(ubound(r) /= (/ 3, 4 /))) error stop 99 + end subroutine + elemental subroutine set(o, i) + integer, intent(out) :: o + integer, intent(in) :: i + o = i + end subroutine + subroutine check_dependencies() + integer, allocatable :: a(:,:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + a(1,:,:) = maxloc(a, dim=1) + if (any(a(1,:,:) /= reshape(data1, (/ 4, 5 /)))) error stop 111 + a(:,:,:) = reshape(data60, shape(a)) + a(:,2,:) = maxloc(a, dim=2) + if (any(a(:,2,:) /= reshape(data2, (/ 3, 5 /)))) error stop 112 + a(:,:,:) = reshape(data60, shape(a)) + a(:,:,5) = maxloc(a, dim=3) + if (any(a(:,:,5) /= reshape(data3, (/ 3, 4 /)))) error stop 113 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(1,:,:), maxloc(a, dim=1)) + if (any(a(1,:,:) /= reshape(data1, (/ 4, 5 /)))) error stop 114 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(:,2,:), maxloc(a, dim=2)) + if (any(a(:,2,:) /= reshape(data2, (/ 3, 5 /)))) error stop 115 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(:,:,5), maxloc(a, dim=3)) + if (any(a(:,:,5) /= reshape(data3, (/ 3, 4 /)))) error stop 116 + end subroutine check_dependencies +end program p diff --git a/gcc/testsuite/gfortran.dg/maxloc_with_dim_and_mask_1.f90 b/gcc/testsuite/gfortran.dg/maxloc_with_dim_and_mask_1.f90 new file mode 100644 index 00000000000..e4fa31430a2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/maxloc_with_dim_and_mask_1.f90 @@ -0,0 +1,452 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline maxloc implementation, +! when the dim and mask argument are present. + +program p + 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_rank_3_true_mask + call check_int_const_shape_rank_3_false_mask + call check_int_const_shape_rank_3_optional_mask_present + call check_int_const_shape_rank_3_optional_mask_absent + call check_int_const_shape_empty_4 + call check_int_alloc_rank_3 + call check_int_alloc_rank_3_true_mask + call check_int_alloc_rank_3_false_mask + call check_int_alloc_empty_4 + call check_real_const_shape_rank_3 + call check_real_const_shape_rank_3_true_mask + call check_real_const_shape_rank_3_false_mask + call check_real_const_shape_rank_3_optional_mask_present + call check_real_const_shape_rank_3_optional_mask_absent + call check_real_const_shape_empty_4 + call check_real_alloc_rank_3 + call check_real_alloc_rank_3_true_mask + call check_real_alloc_rank_3_false_mask + 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 = maxloc(a, dim = 1, mask = m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 11 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 12 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 13 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 14 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 15 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 16 + end subroutine + subroutine check_int_const_shape_rank_3_true_mask() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + r = maxloc(a, dim = 1, mask = .true.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 21 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 22 + r = maxloc(a, dim = 2, mask = .true.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 23 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 24 + r = maxloc(a, dim = 3, mask = .true.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 25 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 26 + end subroutine + subroutine check_int_const_shape_rank_3_false_mask() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + r = maxloc(a, dim = 1, mask = .false.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 31 + if (any(r /= 0)) error stop 32 + r = maxloc(a, dim = 2, mask = .false.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 33 + if (any(r /= 0)) error stop 34 + r = maxloc(a, dim = 3, mask = .false.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 35 + if (any(r /= 0)) error stop 36 + end subroutine + subroutine call_maxloc_int(r, a, d, m) + integer :: a(:,:,:) + integer :: d + logical, optional :: m(:,:,:) + integer, allocatable :: r(:,:) + r = maxloc(a, dim = d, mask = m) + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_present() + integer :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + m = reshape(mask60, shape(m)) + call call_maxloc_int(r, a, 1, m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 41 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 42 + call call_maxloc_int(r, a, 2, m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 43 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 44 + call call_maxloc_int(r, a, 3, 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_rank_3_optional_mask_absent() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + call call_maxloc_int(r, a, 1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 51 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 52 + call call_maxloc_int(r, a, 2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 53 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 54 + call call_maxloc_int(r, a, 3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 55 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 56 + 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 61 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 62 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 63 + if (any(r /= 0)) error stop 64 + r = maxloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 65 + 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 71 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 72 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 73 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 74 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 75 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 76 + end subroutine + subroutine check_int_alloc_rank_3_true_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + r = maxloc(a, dim = 1, mask = .true.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 81 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 82 + r = maxloc(a, dim = 2, mask = .true.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 83 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 84 + r = maxloc(a, dim = 3, mask = .true.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 85 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 86 + end subroutine + subroutine check_int_alloc_rank_3_false_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + r = maxloc(a, dim = 1, mask = .false.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 91 + if (any(r /= 0)) error stop 92 + r = maxloc(a, dim = 2, mask = .false.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 93 + if (any(r /= 0)) error stop 94 + r = maxloc(a, dim = 3, mask = .false.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 95 + if (any(r /= 0)) error stop 96 + 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 101 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 102 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 103 + if (any(r /= 0)) error stop 104 + r = maxloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 105 + 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 111 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 112 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 113 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 114 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 115 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 116 + end subroutine + subroutine check_real_const_shape_rank_3_true_mask() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + r = maxloc(a, dim = 1, mask = .true.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 121 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 122 + r = maxloc(a, dim = 2, mask = .true.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 123 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 124 + r = maxloc(a, dim = 3, mask = .true.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 125 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 126 + end subroutine + subroutine check_real_const_shape_rank_3_false_mask() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + r = maxloc(a, dim = 1, mask = .false.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 131 + if (any(r /= 0)) error stop 132 + r = maxloc(a, dim = 2, mask = .false.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 133 + if (any(r /= 0)) error stop 134 + r = maxloc(a, dim = 3, mask = .false.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 135 + if (any(r /= 0)) error stop 136 + end subroutine + subroutine call_maxloc_real(r, a, d, m) + real :: a(:,:,:) + integer :: d + logical, optional :: m(:,:,:) + integer, allocatable :: r(:,:) + r = maxloc(a, dim = d, mask = m) + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_present() + real :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + m = reshape(mask60, shape(m)) + call call_maxloc_real(r, a, 1, m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 141 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 142 + call call_maxloc_real(r, a, 2, m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 143 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 144 + call call_maxloc_real(r, a, 3, m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 145 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 146 + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_absent() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + call call_maxloc_real(r, a, 1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 151 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 152 + call call_maxloc_real(r, a, 2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 153 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 154 + call call_maxloc_real(r, a, 3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 155 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 156 + 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 161 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 162 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 163 + if (any(r /= 0)) error stop 164 + r = maxloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 165 + 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 171 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 172 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 173 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 174 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 175 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 176 + end subroutine + subroutine check_real_alloc_rank_3_true_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + r = maxloc(a, dim = 1, mask = .true.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 181 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 182 + r = maxloc(a, dim = 2, mask = .true.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 183 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 184 + r = maxloc(a, dim = 3, mask = .true.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 185 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 186 + end subroutine + subroutine check_real_alloc_rank_3_false_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + r = maxloc(a, dim = 1, mask = .false.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 191 + if (any(r /= 0)) error stop 192 + r = maxloc(a, dim = 2, mask = .false.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 193 + if (any(r /= 0)) error stop 194 + r = maxloc(a, dim = 3, mask = .false.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 195 + if (any(r /= 0)) error stop 196 + 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 201 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 202 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 203 + if (any(r /= 0)) error stop 204 + r = maxloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 205 + end subroutine + subroutine check_lower_bounds() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3:5,-1:2,5), m(3:5,-1:2,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 211 + if (any(lbound(r) /= 1)) error stop 212 + if (any(ubound(r) /= (/ 4, 5 /))) error stop 213 + r = maxloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 214 + if (any(lbound(r) /= 1)) error stop 215 + if (any(ubound(r) /= (/ 3, 5 /))) error stop 216 + r = maxloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 217 + if (any(lbound(r) /= 1)) error stop 218 + if (any(ubound(r) /= (/ 3, 4 /))) error stop 219 + end subroutine + elemental subroutine set(o, i) + real, intent(out) :: o + integer, intent(in) :: i + o = i + end subroutine + subroutine check_dependencies() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + allocate(a(3,4,5),m(3,4,5)) + m(:,:,:) = reshape(mask60, shape(m)) + a(:,:,:) = reshape(data60, shape(a)) + a(1,:,:) = maxloc(a, dim = 1, mask = m) + if (any(a(1,:,:) /= reshape(data1m, (/ 4, 5 /)))) error stop 231 + a(:,:,:) = reshape(data60, shape(a)) + a(:,2,:) = maxloc(a, dim = 2, mask = m) + if (any(a(:,2,:) /= reshape(data2m, (/ 3, 5 /)))) error stop 232 + a(:,:,:) = reshape(data60, shape(a)) + a(:,:,5) = maxloc(a, dim = 3, mask = m) + if (any(a(:,:,5) /= reshape(data3m, (/ 3, 4 /)))) error stop 233 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(1,:,:), maxloc(a, dim = 1, mask = m)) + if (any(a(1,:,:) /= reshape(data1m, (/ 4, 5 /)))) error stop 234 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(:,2,:), maxloc(a, dim = 2, mask = m)) + if (any(a(:,2,:) /= reshape(data2m, (/ 3, 5 /)))) error stop 235 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(:,:,5), maxloc(a, dim = 3, mask = m)) + if (any(a(:,:,5) /= reshape(data3m, (/ 3, 4 /)))) error stop 236 + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/minloc_with_dim_1.f90 b/gcc/testsuite/gfortran.dg/minloc_with_dim_1.f90 new file mode 100644 index 00000000000..89dd05e5927 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minloc_with_dim_1.f90 @@ -0,0 +1,201 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline minloc implementation, +! when the dim argument is present. + +program p + 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_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) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + r = minloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 11 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 12 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 13 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 14 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 15 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 16 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + integer, allocatable :: r(:,:,:) + a = reshape((/ integer:: /), shape(a)) + r = minloc(a, dim=1) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 21 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 22 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 23 + if (any(r /= 0)) error stop 24 + r = minloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 25 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + r = minloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 31 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 32 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 33 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 34 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 35 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 36 + end subroutine + subroutine check_int_alloc_empty_4() + integer, allocatable :: a(:,:,:,:) + integer, allocatable :: r(:,:,:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ integer:: /), shape(a)) + r = minloc(a, dim=1) + if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 41 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 42 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 43 + if (any(r /= 0)) error stop 44 + r = minloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 45 + end subroutine + 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 51 + if (any(r /= reshape((/ real:: data1 /), (/ 4, 5 /)))) error stop 52 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 53 + if (any(r /= reshape((/ real:: data2 /), (/ 3, 5 /)))) error stop 54 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 55 + if (any(r /= reshape((/ real:: data3 /), (/ 3, 4 /)))) error stop 56 + 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 61 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 62 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 63 + if (any(r /= 0)) error stop 64 + r = minloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 65 + 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 71 + if (any(r /= reshape((/ real:: data1 /), shape=(/ 4, 5 /)))) error stop 72 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 73 + if (any(r /= reshape((/ real:: data2 /), shape=(/ 3, 5 /)))) error stop 74 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 75 + if (any(r /= reshape((/ real:: data3 /), shape=(/ 3, 4 /)))) error stop 76 + 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 81 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 82 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 83 + if (any(r /= 0)) error stop 84 + r = minloc(a, dim=4) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 85 + end subroutine + subroutine check_lower_bounds() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3:5,-1:2,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + r = minloc(a, dim=1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 91 + if (any(lbound(r) /= 1)) error stop 92 + if (any(ubound(r) /= (/ 4, 5 /))) error stop 93 + r = minloc(a, dim=2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 94 + if (any(lbound(r) /= 1)) error stop 95 + if (any(ubound(r) /= (/ 3, 5 /))) error stop 96 + r = minloc(a, dim=3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 97 + if (any(lbound(r) /= 1)) error stop 98 + if (any(ubound(r) /= (/ 3, 4 /))) error stop 99 + end subroutine + elemental subroutine set(o, i) + integer, intent(out) :: o + integer, intent(in) :: i + o = i + end subroutine + subroutine check_dependencies() + integer, allocatable :: a(:,:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + a(1,:,:) = minloc(a, dim=1) + if (any(a(1,:,:) /= reshape(data1, (/ 4, 5 /)))) error stop 111 + a(:,:,:) = reshape(data60, shape(a)) + a(:,2,:) = minloc(a, dim=2) + if (any(a(:,2,:) /= reshape(data2, (/ 3, 5 /)))) error stop 112 + a(:,:,:) = reshape(data60, shape(a)) + a(:,:,5) = minloc(a, dim=3) + if (any(a(:,:,5) /= reshape(data3, (/ 3, 4 /)))) error stop 113 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(1,:,:), minloc(a, dim=1)) + if (any(a(1,:,:) /= reshape(data1, (/ 4, 5 /)))) error stop 114 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(:,2,:), minloc(a, dim=2)) + if (any(a(:,2,:) /= reshape(data2, (/ 3, 5 /)))) error stop 115 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(:,:,5), minloc(a, dim=3)) + if (any(a(:,:,5) /= reshape(data3, (/ 3, 4 /)))) error stop 116 + end subroutine check_dependencies +end program p diff --git a/gcc/testsuite/gfortran.dg/minloc_with_dim_and_mask_1.f90 b/gcc/testsuite/gfortran.dg/minloc_with_dim_and_mask_1.f90 new file mode 100644 index 00000000000..c5b9665eeb7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minloc_with_dim_and_mask_1.f90 @@ -0,0 +1,452 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline minloc implementation, +! when the dim and mask argument are present. + +program p + 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_rank_3_true_mask + call check_int_const_shape_rank_3_false_mask + call check_int_const_shape_rank_3_optional_mask_present + call check_int_const_shape_rank_3_optional_mask_absent + call check_int_const_shape_empty_4 + call check_int_alloc_rank_3 + call check_int_alloc_rank_3_true_mask + call check_int_alloc_rank_3_false_mask + call check_int_alloc_empty_4 + call check_real_const_shape_rank_3 + call check_real_const_shape_rank_3_true_mask + call check_real_const_shape_rank_3_false_mask + call check_real_const_shape_rank_3_optional_mask_present + call check_real_const_shape_rank_3_optional_mask_absent + call check_real_const_shape_empty_4 + call check_real_alloc_rank_3 + call check_real_alloc_rank_3_true_mask + call check_real_alloc_rank_3_false_mask + 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 11 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 12 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 13 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 14 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 15 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 16 + end subroutine + subroutine check_int_const_shape_rank_3_true_mask() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + r = minloc(a, dim = 1, mask = .true.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 21 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 22 + r = minloc(a, dim = 2, mask = .true.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 23 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 24 + r = minloc(a, dim = 3, mask = .true.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 25 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 26 + end subroutine + subroutine check_int_const_shape_rank_3_false_mask() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + r = minloc(a, dim = 1, mask = .false.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 31 + if (any(r /= 0)) error stop 32 + r = minloc(a, dim = 2, mask = .false.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 33 + if (any(r /= 0)) error stop 34 + r = minloc(a, dim = 3, mask = .false.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 35 + if (any(r /= 0)) error stop 36 + end subroutine + subroutine call_minloc_int(r, a, d, m) + integer :: a(:,:,:) + integer :: d + logical, optional :: m(:,:,:) + integer, allocatable :: r(:,:) + r = minloc(a, dim = d, mask = m) + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_present() + integer :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + m = reshape(mask60, shape(m)) + call call_minloc_int(r, a, 1, m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 41 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 42 + call call_minloc_int(r, a, 2, m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 43 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 44 + call call_minloc_int(r, a, 3, 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_rank_3_optional_mask_absent() + integer :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape(data60, shape(a)) + call call_minloc_int(r, a, 1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 51 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 52 + call call_minloc_int(r, a, 2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 53 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 54 + call call_minloc_int(r, a, 3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 55 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 56 + 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 61 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 62 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 63 + if (any(r /= 0)) error stop 64 + r = minloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 65 + 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 71 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 72 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 73 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 74 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 75 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 76 + end subroutine + subroutine check_int_alloc_rank_3_true_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + r = minloc(a, dim = 1, mask = .true.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 81 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 82 + r = minloc(a, dim = 2, mask = .true.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 83 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 84 + r = minloc(a, dim = 3, mask = .true.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 85 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 86 + end subroutine + subroutine check_int_alloc_rank_3_false_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape(data60, shape(a)) + r = minloc(a, dim = 1, mask = .false.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 91 + if (any(r /= 0)) error stop 92 + r = minloc(a, dim = 2, mask = .false.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 93 + if (any(r /= 0)) error stop 94 + r = minloc(a, dim = 3, mask = .false.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 95 + if (any(r /= 0)) error stop 96 + 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 101 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 102 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 103 + if (any(r /= 0)) error stop 104 + r = minloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 105 + 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 111 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 112 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 113 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 114 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 115 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 116 + end subroutine + subroutine check_real_const_shape_rank_3_true_mask() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + r = minloc(a, dim = 1, mask = .true.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 121 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 122 + r = minloc(a, dim = 2, mask = .true.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 123 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 124 + r = minloc(a, dim = 3, mask = .true.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 125 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 126 + end subroutine + subroutine check_real_const_shape_rank_3_false_mask() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + r = minloc(a, dim = 1, mask = .false.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 131 + if (any(r /= 0)) error stop 132 + r = minloc(a, dim = 2, mask = .false.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 133 + if (any(r /= 0)) error stop 134 + r = minloc(a, dim = 3, mask = .false.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 135 + if (any(r /= 0)) error stop 136 + end subroutine + subroutine call_minloc_real(r, a, d, m) + real :: a(:,:,:) + integer :: d + logical, optional :: m(:,:,:) + integer, allocatable :: r(:,:) + r = minloc(a, dim = d, mask = m) + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_present() + real :: a(3,4,5) + logical :: m(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + m = reshape(mask60, shape(m)) + call call_minloc_real(r, a, 1, m) + if (any(shape(r) /= (/ 4, 5 /))) error stop 141 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 142 + call call_minloc_real(r, a, 2, m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 143 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 144 + call call_minloc_real(r, a, 3, m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 145 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 146 + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_absent() + real :: a(3,4,5) + integer, allocatable :: r(:,:) + a = reshape((/ real:: data60 /), shape(a)) + call call_minloc_real(r, a, 1) + if (any(shape(r) /= (/ 4, 5 /))) error stop 151 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 152 + call call_minloc_real(r, a, 2) + if (any(shape(r) /= (/ 3, 5 /))) error stop 153 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 154 + call call_minloc_real(r, a, 3) + if (any(shape(r) /= (/ 3, 4 /))) error stop 155 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 156 + 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 161 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 162 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 163 + if (any(r /= 0)) error stop 164 + r = minloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 165 + 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 171 + if (any(r /= reshape(data1m, (/ 4, 5 /)))) error stop 172 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 173 + if (any(r /= reshape(data2m, (/ 3, 5 /)))) error stop 174 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 175 + if (any(r /= reshape(data3m, (/ 3, 4 /)))) error stop 176 + end subroutine + subroutine check_real_alloc_rank_3_true_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + r = minloc(a, dim = 1, mask = .true.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 181 + if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 182 + r = minloc(a, dim = 2, mask = .true.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 183 + if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 184 + r = minloc(a, dim = 3, mask = .true.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 185 + if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 186 + end subroutine + subroutine check_real_alloc_rank_3_false_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3,4,5)) + a(:,:,:) = reshape((/ real:: data60 /), shape(a)) + r = minloc(a, dim = 1, mask = .false.) + if (any(shape(r) /= (/ 4, 5 /))) error stop 191 + if (any(r /= 0)) error stop 192 + r = minloc(a, dim = 2, mask = .false.) + if (any(shape(r) /= (/ 3, 5 /))) error stop 193 + if (any(r /= 0)) error stop 194 + r = minloc(a, dim = 3, mask = .false.) + if (any(shape(r) /= (/ 3, 4 /))) error stop 195 + if (any(r /= 0)) error stop 196 + 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 201 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 202 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 203 + if (any(r /= 0)) error stop 204 + r = minloc(a, dim = 4, mask = m) + if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 205 + end subroutine + subroutine check_lower_bounds() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:,:) + allocate(a(3:5,-1:2,5), m(3:5,-1:2,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 211 + if (any(lbound(r) /= 1)) error stop 212 + if (any(ubound(r) /= (/ 4, 5 /))) error stop 213 + r = minloc(a, dim = 2, mask = m) + if (any(shape(r) /= (/ 3, 5 /))) error stop 214 + if (any(lbound(r) /= 1)) error stop 215 + if (any(ubound(r) /= (/ 3, 5 /))) error stop 216 + r = minloc(a, dim = 3, mask = m) + if (any(shape(r) /= (/ 3, 4 /))) error stop 217 + if (any(lbound(r) /= 1)) error stop 218 + if (any(ubound(r) /= (/ 3, 4 /))) error stop 219 + end subroutine + elemental subroutine set(o, i) + real, intent(out) :: o + integer, intent(in) :: i + o = i + end subroutine + subroutine check_dependencies() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + allocate(a(3,4,5),m(3,4,5)) + m(:,:,:) = reshape(mask60, shape(m)) + a(:,:,:) = reshape(data60, shape(a)) + a(1,:,:) = minloc(a, dim = 1, mask = m) + if (any(a(1,:,:) /= reshape(data1m, (/ 4, 5 /)))) error stop 231 + a(:,:,:) = reshape(data60, shape(a)) + a(:,2,:) = minloc(a, dim = 2, mask = m) + if (any(a(:,2,:) /= reshape(data2m, (/ 3, 5 /)))) error stop 232 + a(:,:,:) = reshape(data60, shape(a)) + a(:,:,5) = minloc(a, dim = 3, mask = m) + if (any(a(:,:,5) /= reshape(data3m, (/ 3, 4 /)))) error stop 233 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(1,:,:), minloc(a, dim = 1, mask = m)) + if (any(a(1,:,:) /= reshape(data1m, (/ 4, 5 /)))) error stop 234 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(:,2,:), minloc(a, dim = 2, mask = m)) + if (any(a(:,2,:) /= reshape(data2m, (/ 3, 5 /)))) error stop 235 + a(:,:,:) = reshape(data60, shape(a)) + call set(a(:,:,5), minloc(a, dim = 3, mask = m)) + if (any(a(:,:,5) /= reshape(data3m, (/ 3, 4 /)))) error stop 236 + end subroutine +end program p

[1/7] fortran: Add tests covering inline MINLOC/MAXLOC with DIM [PR90608]

Commit Message

Patch