From patchwork Fri Aug 23 08:31:41 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1975930 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; unprotected) header.d=orange.fr header.i=@orange.fr header.a=rsa-sha256 header.s=t20230301 header.b=OHXIkodv; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4Wqtjb70s0z1yXY for ; Fri, 23 Aug 2024 18:37:23 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 403543882123 for ; Fri, 23 Aug 2024 08:37:22 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from msa.smtpout.orange.fr (msa-210.smtpout.orange.fr [193.252.23.210]) by sourceware.org (Postfix) with ESMTPS id 2C45B3839DC6; Fri, 23 Aug 2024 08:31:57 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 2C45B3839DC6 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=orange.fr Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=orange.fr ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 2C45B3839DC6 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=193.252.23.210 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401924; cv=none; b=CptgbRA6QuUW8etKEmyGUFG0d4aA3dxJgZ7rUUXTOGWJXwePnaG/P7oczN8jL48X0VkblnOnBEByEaoVTGcxM03p/aK0LKdNSJk08+MpaG9tWiAjOVCeqIfwhvcK1aLK3yHsQquITGPGY8F4qFma6q3Ru8ALRyi0BZm8++I1y3Y= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1724401924; c=relaxed/simple; bh=lqj4215wh+myXQZQyDQ9UKoN4TDdhOnWWNDgTkNHvrg=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=mMpzJyZlOfgz/zPc7DwcAu8H47dDrI2wVmpFEtZ8ulcnTDy+H4Mg2L4aaca5QT3DLVJiIo/J0fXL/A/lWZalo4WLf0ElyHrHMBzwxzDhooh0kaselwlz4dx2WBPRA35jkx22k/wNmt8SlTONL8y+3g2PAZuuo6MHdkO8xwHEPYg= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id hPi1srBoShYnYhPi7sjylk; Fri, 23 Aug 2024 10:31:56 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1724401916; bh=E0oyB+4lwLkeq8EMfwHZXX9AM6E2J2qRi2DJmlQn9bI=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=OHXIkodv2mMYmqlOCvwfUxxD3iFEQxxO5uIfY8ei1sWgkJ4trrxB/8OuD7zd7sly1 O79yxMgxtguU8hqJeNqsMJ/376UANgKAr7lsWrHCOYV4jO3fKJBkoZnBCgoS+u1lD6 UNAdTS1yBYJ8+k+XWDw2hL2NyStP3oHXwMjfMI5/FOoeyRgkYaBPevrb9edp/Ro/sj Ydy3swCUDx16I5RAKFIDYaSw/ivqG7r/eQomcX0xdgDqUIphXB/nQC8a2VYNo62riU u5/BTumxIt8fBYcxpWSKwaTHwDN3GiNEtVSYvYi85UKmU6FMBGyfpZ2DPhUk99RRuA w1N+o8pZF4aaA== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Fri, 23 Aug 2024 10:31:56 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: [PATCH v3 01/10] fortran: Add tests covering inline MINLOC/MAXLOC without DIM [PR90608] Date: Fri, 23 Aug 2024 10:31:41 +0200 Message-ID: <20240823083150.149099-2-morin-mikael@orange.fr> X-Mailer: git-send-email 2.43.0 In-Reply-To: <20240823083150.149099-1-morin-mikael@orange.fr> References: <20240823083150.149099-1-morin-mikael@orange.fr> MIME-Version: 1.0 X-Spam-Status: No, score=-11.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Mikael Morin Add the tests covering the various cases for which we are about to implement inline expansion of MINLOC and MAXLOC. Those are cases where the DIM argument is not present. PR fortran/90608 gcc/testsuite/ChangeLog: * gfortran.dg/ieee/maxloc_nan_1.f90: New test. * gfortran.dg/ieee/minloc_nan_1.f90: New test. * gfortran.dg/maxloc_7.f90: New test. * gfortran.dg/maxloc_with_mask_1.f90: New test. * gfortran.dg/minloc_8.f90: New test. * gfortran.dg/minloc_with_mask_1.f90: New test. --- .../gfortran.dg/ieee/maxloc_nan_1.f90 | 44 +++ .../gfortran.dg/ieee/minloc_nan_1.f90 | 44 +++ gcc/testsuite/gfortran.dg/maxloc_7.f90 | 208 ++++++++++ .../gfortran.dg/maxloc_with_mask_1.f90 | 373 ++++++++++++++++++ gcc/testsuite/gfortran.dg/minloc_8.f90 | 208 ++++++++++ .../gfortran.dg/minloc_with_mask_1.f90 | 372 +++++++++++++++++ 6 files changed, 1249 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/ieee/maxloc_nan_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/ieee/minloc_nan_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/maxloc_7.f90 create mode 100644 gcc/testsuite/gfortran.dg/maxloc_with_mask_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/minloc_8.f90 create mode 100644 gcc/testsuite/gfortran.dg/minloc_with_mask_1.f90 diff --git a/gcc/testsuite/gfortran.dg/ieee/maxloc_nan_1.f90 b/gcc/testsuite/gfortran.dg/ieee/maxloc_nan_1.f90 new file mode 100644 index 00000000000..329b54e8e1f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/maxloc_nan_1.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MAXLOC implementation, +! when ARRAY is filled with NANs. + +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 :: m(:) + if (.not. ieee_support_nan(nan)) return + nan = ieee_value(nan, ieee_quiet_nan) + allocate(a(3,3,3), source = nan) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 32 + if (any(m /= (/ 1, 1, 1 /))) stop 35 + 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(3,3,3), source = nan) + allocate(m(3,3,3)) + 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., .true. , & + .true. , .true. /), shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 62 + if (any(r /= (/ 3, 1, 1 /))) stop 65 + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/ieee/minloc_nan_1.f90 b/gcc/testsuite/gfortran.dg/ieee/minloc_nan_1.f90 new file mode 100644 index 00000000000..8f71b4c4398 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ieee/minloc_nan_1.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MINLOC implementation, +! when ARRAY is filled with NANs. + +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 :: m(:) + if (.not. ieee_support_nan(nan)) return + nan = ieee_value(nan, ieee_quiet_nan) + allocate(a(3,3,3), source = nan) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 32 + if (any(m /= (/ 1, 1, 1 /))) stop 35 + 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(3,3,3), source = nan) + allocate(m(3,3,3)) + 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., .true. , & + .true. , .true. /), shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 62 + if (any(r /= (/ 3, 1, 1 /))) stop 65 + end subroutine +end program p diff --git a/gcc/testsuite/gfortran.dg/maxloc_7.f90 b/gcc/testsuite/gfortran.dg/maxloc_7.f90 new file mode 100644 index 00000000000..0e57f0661c0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/maxloc_7.f90 @@ -0,0 +1,208 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MAXLOC implementation, +! when there is no optional argument. + +program p + implicit none + integer, parameter :: data5(*) = (/ 1, 7, 2, 7, 0 /) + integer, parameter :: data64(*) = (/ 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, 2, 5, 4, 6 /) + call check_int_const_shape_rank_1 + call check_int_const_shape_rank_3 + call check_int_const_shape_empty_4 + call check_int_alloc_rank_1 + call check_int_alloc_rank_3 + call check_int_alloc_empty_4 + call check_real_const_shape_rank_1 + call check_real_const_shape_rank_3 + call check_real_const_shape_empty_4 + call check_real_alloc_rank_1 + call check_real_alloc_rank_3 + call check_real_alloc_empty_4 + call check_int_lower_bounds + call check_real_lower_bounds + call check_dependencies +contains + subroutine check_int_const_shape_rank_1() + integer :: a(5) + integer, allocatable :: m(:) + a = data5 + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 11 + if (any(m /= (/ 2 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape(data64, shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 21 + if (any(m /= (/ 2, 2, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ integer:: /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 4) stop 31 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 32 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = data5 + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 41 + if (any(m /= (/ 2 /))) stop 42 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 51 + if (any(m /= (/ 2, 2, 1 /))) stop 52 + end subroutine + subroutine check_int_alloc_empty_4() + integer, allocatable :: a(:,:,:,:) + integer, allocatable :: m(:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ integer:: /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 4) stop 61 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 62 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(5) + integer, allocatable :: m(:) + a = (/ real:: data5 /) + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 71 + if (any(m /= (/ 2 /))) stop 72 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape((/ real:: data64 /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 81 + if (any(m /= (/ 2, 2, 1 /))) stop 82 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ real:: /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 4) stop 91 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 92 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = (/ real:: data5 /) + m = maxloc(a) + if (size(m, dim=1) /= 1) stop 111 + if (any(m /= (/ 2 /))) stop 112 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 121 + if (any(m /= (/ 2, 2, 1 /))) stop 122 + end subroutine + subroutine check_real_alloc_empty_4() + real, allocatable :: a(:,:,:,:) + integer, allocatable :: m(:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ real:: /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 4) stop 131 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 132 + end subroutine + subroutine check_int_lower_bounds() + integer, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(3:6,-1:2,4)) + a(:,:,:) = reshape(data64, shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 141 + if (any(m /= (/ 2, 2, 1 /))) stop 142 + end subroutine + subroutine check_real_lower_bounds() + real, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(3:6,-1:2,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = maxloc(a) + if (size(m, dim=1) /= 3) stop 151 + if (any(m /= (/ 2, 2, 1 /))) stop 152 + 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,3,3)) + ! Direct assignment + a(:,:,:) = reshape(data64(1:27), shape(a)) + a(1,1,:) = maxloc(a) + if (any(a(1,1,:) /= (/ 3, 2, 1 /))) stop 171 + a(:,:,:) = reshape(data64(2:28), shape(a)) + a(3,3,:) = maxloc(a) + if (any(a(3,3,:) /= (/ 2, 2, 1 /))) stop 172 + a(:,:,:) = reshape(data64(3:29), shape(a)) + a(1,:,1) = maxloc(a) + if (any(a(1,:,1) /= (/ 1, 2, 1 /))) stop 173 + a(:,:,:) = reshape(data64(5:31), shape(a)) + a(2,:,2) = maxloc(a) + if (any(a(2,:,2) /= (/ 2, 1, 1 /))) stop 174 + a(:,:,:) = reshape(data64(6:32), shape(a)) + a(3,:,3) = maxloc(a) + if (any(a(3,:,3) /= (/ 1, 1, 1 /))) stop 175 + a(:,:,:) = reshape(data64(7:33), shape(a)) + a(:,1,1) = maxloc(a) + if (any(a(:,1,1) /= (/ 3, 2, 2 /))) stop 176 + a(:,:,:) = reshape(data64(8:34), shape(a)) + a(:,3,3) = maxloc(a) + if (any(a(:,3,3) /= (/ 2, 2, 2 /))) stop 177 + ! Subroutine assignment + a(:,:,:) = reshape(data64(9:35), shape(a)) + call set(a(1,1,:), maxloc(a)) + if (any(a(1,1,:) /= (/ 1, 2, 2 /))) stop 181 + a(:,:,:) = reshape(data64(10:36), shape(a)) + call set(a(3,3,:), maxloc(a)) + if (any(a(3,3,:) /= (/ 3, 1, 2 /))) stop 182 + a(:,:,:) = reshape(data64(11:37), shape(a)) + call set(a(1,:,1), maxloc(a)) + if (any(a(1,:,1) /= (/ 2, 1, 2 /))) stop 183 + a(:,:,:) = reshape(data64(12:38), shape(a)) + call set(a(2,:,2), maxloc(a)) + if (any(a(2,:,2) /= (/ 1, 1, 2 /))) stop 184 + a(:,:,:) = reshape(data64(13:39), shape(a)) + call set(a(3,:,3), maxloc(a)) + if (any(a(3,:,3) /= (/ 3, 3, 1 /))) stop 185 + a(:,:,:) = reshape(data64(14:40), shape(a)) + call set(a(:,1,1), maxloc(a)) + if (any(a(:,1,1) /= (/ 2, 3, 1 /))) stop 186 + a(:,:,:) = reshape(data64(15:41), shape(a)) + call set(a(:,3,3), maxloc(a)) + if (any(a(:,3,3) /= (/ 1, 3, 1 /))) stop 187 + call set(a(1,:,:), maxloc(a, dim=1)) + end subroutine check_dependencies +end program p diff --git a/gcc/testsuite/gfortran.dg/maxloc_with_mask_1.f90 b/gcc/testsuite/gfortran.dg/maxloc_with_mask_1.f90 new file mode 100644 index 00000000000..b8d5dda6761 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/maxloc_with_mask_1.f90 @@ -0,0 +1,373 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MAXLOC implementation, +! when there is a mask argument. + +program p + implicit none + integer, parameter :: data10(*) = (/ 7, 4, 7, 6, 6, 4, 6, 3, 9, 8 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + integer, parameter :: data64(*) = (/ 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, 2, 5, 4, 6 /) + logical, parameter :: mask64(*) = (/ .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. , & + .true. , .false., .false., .false. /) + call check_int_const_shape_rank_1 + 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_1 + 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_1 + 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_1 + 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_1() + integer :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = data10 + m = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 11 + if (any(r /= (/ 5 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 21 + if (any(r /= (/ 2, 3, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_rank_3_true_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 31 + if (any(r /= (/ 2, 2, 1 /))) stop 32 + end subroutine + subroutine check_int_const_shape_rank_3_false_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 41 + if (any(r /= (/ 0, 0, 0 /))) stop 42 + end subroutine + subroutine call_maxloc_int(r, a, m) + integer :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = maxloc(a, mask = m) + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_present() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + call call_maxloc_int(r, a, m) + if (size(r, dim = 1) /= 3) stop 51 + if (any(r /= (/ 2, 3, 1 /))) stop 52 + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_absent() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + call call_maxloc_int(r, a) + if (size(r, dim = 1) /= 3) stop 61 + if (any(r /= (/ 2, 2, 1 /))) stop 62 + 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, mask = m) + if (size(r, dim = 1) /= 4) stop 71 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 72 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = data10 + m(:) = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 81 + if (any(r /= (/ 5 /))) stop 82 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 91 + if (any(r /= (/ 2, 3, 1 /))) stop 92 + end subroutine + subroutine check_int_alloc_rank_3_true_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 101 + if (any(r /= (/ 2, 2, 1 /))) stop 102 + end subroutine + subroutine check_int_alloc_rank_3_false_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 111 + if (any(r /= (/ 0, 0, 0 /))) stop 112 + 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, mask = m) + if (size(r, dim = 1) /= 4) stop 121 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 122 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = (/ real:: data10 /) + m = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 131 + if (any(r /= (/ 5 /))) stop 132 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 141 + if (any(r /= (/ 2, 3, 1 /))) stop 142 + end subroutine + subroutine check_real_const_shape_rank_3_true_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 151 + if (any(r /= (/ 2, 2, 1 /))) stop 152 + end subroutine + subroutine check_real_const_shape_rank_3_false_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 161 + if (any(r /= (/ 0, 0, 0 /))) stop 162 + end subroutine + subroutine call_maxloc_real(r, a, m) + real :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = maxloc(a, mask = m) + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_present() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + call call_maxloc_real(r, a, m) + if (size(r, dim = 1) /= 3) stop 171 + if (any(r /= (/ 2, 3, 1 /))) stop 172 + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_absent() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + call call_maxloc_real(r, a) + if (size(r, dim = 1) /= 3) stop 181 + if (any(r /= (/ 2, 2, 1 /))) stop 182 + 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, mask = m) + if (size(r, dim = 1) /= 4) stop 191 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 192 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = (/ real:: data10 /) + m(:) = mask10 + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 201 + if (any(r /= (/ 5 /))) stop 202 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 211 + if (any(r /= (/ 2, 3, 1 /))) stop 212 + end subroutine + subroutine check_real_alloc_rank_3_true_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 221 + if (any(r /= (/ 2, 2, 1 /))) stop 222 + end subroutine + subroutine check_real_alloc_rank_3_false_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = maxloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 231 + if (any(r /= (/ 0, 0, 0 /))) stop 232 + 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, mask = m) + if (size(r, dim = 1) /= 4) stop 241 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 242 + end subroutine + subroutine check_lower_bounds() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(3:6,-1:2,4), m(3:6,-1:2,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + r = maxloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 251 + if (any(r /= (/ 2, 3, 1 /))) stop 252 + 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,3,3)) + ! Direct assignment + a(:,:,:) = reshape(data64(1:27), shape(a)) + a(1,1,:) = maxloc(a, mask=a>1) + print *, a(1,1,:) + if (any(a(1,1,:) /= (/ 3, 2, 1 /))) stop 171 + a(:,:,:) = reshape(data64(2:28), shape(a)) + a(3,3,:) = maxloc(a, mask=a>1) + if (any(a(3,3,:) /= (/ 2, 2, 1 /))) stop 172 + a(:,:,:) = reshape(data64(3:29), shape(a)) + a(1,:,1) = maxloc(a, mask=a>1) + if (any(a(1,:,1) /= (/ 1, 2, 1 /))) stop 173 + a(:,:,:) = reshape(data64(5:31), shape(a)) + a(2,:,2) = maxloc(a, mask=a>1) + if (any(a(2,:,2) /= (/ 2, 1, 1 /))) stop 174 + a(:,:,:) = reshape(data64(6:32), shape(a)) + a(3,:,3) = maxloc(a, mask=a>1) + if (any(a(3,:,3) /= (/ 1, 1, 1 /))) stop 175 + a(:,:,:) = reshape(data64(7:33), shape(a)) + a(:,1,1) = maxloc(a, mask=a>1) + if (any(a(:,1,1) /= (/ 3, 2, 2 /))) stop 176 + a(:,:,:) = reshape(data64(8:34), shape(a)) + a(:,3,3) = maxloc(a, mask=a>1) + if (any(a(:,3,3) /= (/ 2, 2, 2 /))) stop 177 + ! Subroutine assignment + a(:,:,:) = reshape(data64(9:35), shape(a)) + call set(a(1,1,:), maxloc(a, mask=a>1)) + if (any(a(1,1,:) /= (/ 1, 2, 2 /))) stop 181 + a(:,:,:) = reshape(data64(10:36), shape(a)) + call set(a(3,3,:), maxloc(a, mask=a>1)) + if (any(a(3,3,:) /= (/ 3, 1, 2 /))) stop 182 + a(:,:,:) = reshape(data64(11:37), shape(a)) + call set(a(1,:,1), maxloc(a, mask=a>1)) + if (any(a(1,:,1) /= (/ 2, 1, 2 /))) stop 183 + a(:,:,:) = reshape(data64(12:38), shape(a)) + call set(a(2,:,2), maxloc(a, mask=a>1)) + if (any(a(2,:,2) /= (/ 1, 1, 2 /))) stop 184 + a(:,:,:) = reshape(data64(13:39), shape(a)) + call set(a(3,:,3), maxloc(a, mask=a>1)) + if (any(a(3,:,3) /= (/ 3, 3, 1 /))) stop 185 + a(:,:,:) = reshape(data64(14:40), shape(a)) + call set(a(:,1,1), maxloc(a, mask=a>1)) + if (any(a(:,1,1) /= (/ 2, 3, 1 /))) stop 186 + a(:,:,:) = reshape(data64(15:41), shape(a)) + call set(a(:,3,3), maxloc(a, mask=a>1)) + if (any(a(:,3,3) /= (/ 1, 3, 1 /))) stop 187 + call set(a(1,:,:), maxloc(a, dim=1)) + end subroutine check_dependencies +end program p diff --git a/gcc/testsuite/gfortran.dg/minloc_8.f90 b/gcc/testsuite/gfortran.dg/minloc_8.f90 new file mode 100644 index 00000000000..da28df8f133 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minloc_8.f90 @@ -0,0 +1,208 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MINLOC implementation, +! when there is no optional argument. + +program p + implicit none + integer, parameter :: data5(*) = (/ 8, 2, 7, 2, 9 /) + integer, parameter :: data64(*) = (/ 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, 7, 4, 5, 3 /) + call check_int_const_shape_rank_1 + call check_int_const_shape_rank_3 + call check_int_const_shape_empty_4 + call check_int_alloc_rank_1 + call check_int_alloc_rank_3 + call check_int_alloc_empty_4 + call check_real_const_shape_rank_1 + call check_real_const_shape_rank_3 + call check_real_const_shape_empty_4 + call check_real_alloc_rank_1 + call check_real_alloc_rank_3 + call check_real_alloc_empty_4 + call check_int_lower_bounds + call check_real_lower_bounds + call check_dependencies +contains + subroutine check_int_const_shape_rank_1() + integer :: a(5) + integer, allocatable :: m(:) + a = data5 + m = minloc(a) + if (size(m, dim=1) /= 1) stop 11 + if (any(m /= (/ 2 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape(data64, shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 21 + if (any(m /= (/ 2, 2, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_empty_4() + integer :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ integer:: /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 4) stop 31 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 32 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = data5 + m = minloc(a) + if (size(m, dim=1) /= 1) stop 41 + if (any(m /= (/ 2 /))) stop 42 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 51 + if (any(m /= (/ 2, 2, 1 /))) stop 52 + end subroutine + subroutine check_int_alloc_empty_4() + integer, allocatable :: a(:,:,:,:) + integer, allocatable :: m(:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ integer:: /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 4) stop 61 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 62 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(5) + integer, allocatable :: m(:) + a = (/ real:: data5 /) + m = minloc(a) + if (size(m, dim=1) /= 1) stop 71 + if (any(m /= (/ 2 /))) stop 72 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + integer, allocatable :: m(:) + a = reshape((/ real:: data64 /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 81 + if (any(m /= (/ 2, 2, 1 /))) stop 82 + end subroutine + subroutine check_real_const_shape_empty_4() + real :: a(9,3,0,7) + integer, allocatable :: m(:) + a = reshape((/ real:: /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 4) stop 91 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 92 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + integer, allocatable :: m(:) + allocate(a(5)) + a(:) = (/ real:: data5 /) + m = minloc(a) + if (size(m, dim=1) /= 1) stop 111 + if (any(m /= (/ 2 /))) stop 112 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 121 + if (any(m /= (/ 2, 2, 1 /))) stop 122 + end subroutine + subroutine check_real_alloc_empty_4() + real, allocatable :: a(:,:,:,:) + integer, allocatable :: m(:) + allocate(a(9,3,0,7)) + a(:,:,:,:) = reshape((/ real:: /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 4) stop 131 + if (any(m /= (/ 0, 0, 0, 0 /))) stop 132 + end subroutine + subroutine check_int_lower_bounds() + integer, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(3:6,-1:2,4)) + a(:,:,:) = reshape(data64, shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 141 + if (any(m /= (/ 2, 2, 1 /))) stop 142 + end subroutine + subroutine check_real_lower_bounds() + real, allocatable :: a(:,:,:) + integer, allocatable :: m(:) + allocate(a(3:6,-1:2,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = minloc(a) + if (size(m, dim=1) /= 3) stop 151 + if (any(m /= (/ 2, 2, 1 /))) stop 152 + 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,3,3)) + ! Direct assignment + a(:,:,:) = reshape(data64(1:27), shape(a)) + a(1,1,:) = minloc(a) + if (any(a(1,1,:) /= (/ 3, 2, 1 /))) stop 171 + a(:,:,:) = reshape(data64(2:28), shape(a)) + a(3,3,:) = minloc(a) + if (any(a(3,3,:) /= (/ 2, 2, 1 /))) stop 172 + a(:,:,:) = reshape(data64(3:29), shape(a)) + a(1,:,1) = minloc(a) + if (any(a(1,:,1) /= (/ 1, 2, 1 /))) stop 173 + a(:,:,:) = reshape(data64(5:31), shape(a)) + a(2,:,2) = minloc(a) + if (any(a(2,:,2) /= (/ 2, 1, 1 /))) stop 174 + a(:,:,:) = reshape(data64(6:32), shape(a)) + a(3,:,3) = minloc(a) + if (any(a(3,:,3) /= (/ 1, 1, 1 /))) stop 175 + a(:,:,:) = reshape(data64(7:33), shape(a)) + a(:,1,1) = minloc(a) + if (any(a(:,1,1) /= (/ 3, 2, 2 /))) stop 176 + a(:,:,:) = reshape(data64(8:34), shape(a)) + a(:,3,3) = minloc(a) + if (any(a(:,3,3) /= (/ 2, 2, 2 /))) stop 177 + ! Subroutine assignment + a(:,:,:) = reshape(data64(9:35), shape(a)) + call set(a(1,1,:), minloc(a)) + if (any(a(1,1,:) /= (/ 1, 2, 2 /))) stop 181 + a(:,:,:) = reshape(data64(10:36), shape(a)) + call set(a(3,3,:), minloc(a)) + if (any(a(3,3,:) /= (/ 3, 1, 2 /))) stop 182 + a(:,:,:) = reshape(data64(11:37), shape(a)) + call set(a(1,:,1), minloc(a)) + if (any(a(1,:,1) /= (/ 2, 1, 2 /))) stop 183 + a(:,:,:) = reshape(data64(12:38), shape(a)) + call set(a(2,:,2), minloc(a)) + if (any(a(2,:,2) /= (/ 1, 1, 2 /))) stop 184 + a(:,:,:) = reshape(data64(13:39), shape(a)) + call set(a(3,:,3), minloc(a)) + if (any(a(3,:,3) /= (/ 3, 3, 1 /))) stop 185 + a(:,:,:) = reshape(data64(14:40), shape(a)) + call set(a(:,1,1), minloc(a)) + if (any(a(:,1,1) /= (/ 2, 3, 1 /))) stop 186 + a(:,:,:) = reshape(data64(15:41), shape(a)) + call set(a(:,3,3), minloc(a)) + if (any(a(:,3,3) /= (/ 1, 3, 1 /))) stop 187 + call set(a(1,:,:), minloc(a, dim=1)) + end subroutine check_dependencies +end program p diff --git a/gcc/testsuite/gfortran.dg/minloc_with_mask_1.f90 b/gcc/testsuite/gfortran.dg/minloc_with_mask_1.f90 new file mode 100644 index 00000000000..8012652b2bf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/minloc_with_mask_1.f90 @@ -0,0 +1,372 @@ +! { dg-do run } +! +! PR fortran/90608 +! Check the correct behaviour of the inline MINLOC implementation, +! when there is a mask argument. + +program p + implicit none + integer, parameter :: data10(*) = (/ 2, 5, 2, 3, 3, 5, 3, 6, 0, 1 /) + logical, parameter :: mask10(*) = (/ .false., .true., .false., & + .false., .true., .true., & + .true. , .true., .false., & + .false. /) + integer, parameter :: data64(*) = (/ 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, 7, 4, 5, 3 /) + logical, parameter :: mask64(*) = (/ .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. , & + .true. , .false., .false., .false. /) + call check_int_const_shape_rank_1 + 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_1 + 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_1 + 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_1 + 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_1() + integer :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = data10 + m = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 11 + if (any(r /= (/ 5 /))) stop 12 + end subroutine + subroutine check_int_const_shape_rank_3() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 21 + if (any(r /= (/ 2, 3, 1 /))) stop 22 + end subroutine + subroutine check_int_const_shape_rank_3_true_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 31 + if (any(r /= (/ 2, 2, 1 /))) stop 32 + end subroutine + subroutine check_int_const_shape_rank_3_false_mask() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 41 + if (any(r /= (/ 0, 0, 0 /))) stop 42 + end subroutine + subroutine call_minloc_int(r, a, m) + integer :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = minloc(a, mask = m) + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_present() + integer :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + m = reshape(mask64, shape(m)) + call call_minloc_int(r, a, m) + if (size(r, dim = 1) /= 3) stop 51 + if (any(r /= (/ 2, 3, 1 /))) stop 52 + end subroutine + subroutine check_int_const_shape_rank_3_optional_mask_absent() + integer :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape(data64, shape(a)) + call call_minloc_int(r, a) + if (size(r, dim = 1) /= 3) stop 61 + if (any(r /= (/ 2, 2, 1 /))) stop 62 + 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, mask = m) + if (size(r, dim = 1) /= 4) stop 71 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 72 + end subroutine + subroutine check_int_alloc_rank_1() + integer, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = data10 + m(:) = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 81 + if (any(r /= (/ 5 /))) stop 82 + end subroutine + subroutine check_int_alloc_rank_3() + integer, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 91 + if (any(r /= (/ 2, 3, 1 /))) stop 92 + end subroutine + subroutine check_int_alloc_rank_3_true_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 101 + if (any(r /= (/ 2, 2, 1 /))) stop 102 + end subroutine + subroutine check_int_alloc_rank_3_false_mask() + integer, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape(data64, shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 111 + if (any(r /= (/ 0, 0, 0 /))) stop 112 + 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, mask = m) + if (size(r, dim = 1) /= 4) stop 121 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 122 + end subroutine + subroutine check_real_const_shape_rank_1() + real :: a(10) + logical :: m(10) + integer, allocatable :: r(:) + a = (/ real:: data10 /) + m = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 131 + if (any(r /= (/ 5 /))) stop 132 + end subroutine + subroutine check_real_const_shape_rank_3() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 141 + if (any(r /= (/ 2, 3, 1 /))) stop 142 + end subroutine + subroutine check_real_const_shape_rank_3_true_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 151 + if (any(r /= (/ 2, 2, 1 /))) stop 152 + end subroutine + subroutine check_real_const_shape_rank_3_false_mask() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 161 + if (any(r /= (/ 0, 0, 0 /))) stop 162 + end subroutine + subroutine call_minloc_real(r, a, m) + real :: a(:,:,:) + logical, optional :: m(:,:,:) + integer, allocatable :: r(:) + r = minloc(a, mask = m) + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_present() + real :: a(4,4,4) + logical :: m(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + call call_minloc_real(r, a, m) + if (size(r, dim = 1) /= 3) stop 171 + if (any(r /= (/ 2, 3, 1 /))) stop 172 + end subroutine + subroutine check_real_const_shape_rank_3_optional_mask_absent() + real :: a(4,4,4) + integer, allocatable :: r(:) + a = reshape((/ real:: data64 /), shape(a)) + call call_minloc_real(r, a) + if (size(r, dim = 1) /= 3) stop 181 + if (any(r /= (/ 2, 2, 1 /))) stop 182 + 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, mask = m) + if (size(r, dim = 1) /= 4) stop 191 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 192 + end subroutine + subroutine check_real_alloc_rank_1() + real, allocatable :: a(:) + logical, allocatable :: m(:) + integer, allocatable :: r(:) + allocate(a(10), m(10)) + a(:) = (/ real:: data10 /) + m(:) = mask10 + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 1) stop 201 + if (any(r /= (/ 5 /))) stop 202 + end subroutine + subroutine check_real_alloc_rank_3() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4), m(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m(:,:,:) = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 211 + if (any(r /= (/ 2, 3, 1 /))) stop 212 + end subroutine + subroutine check_real_alloc_rank_3_true_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .true.) + if (size(r, dim = 1) /= 3) stop 221 + if (any(r /= (/ 2, 2, 1 /))) stop 222 + end subroutine + subroutine check_real_alloc_rank_3_false_mask() + real, allocatable :: a(:,:,:) + integer, allocatable :: r(:) + allocate(a(4,4,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + r = minloc(a, mask = .false.) + if (size(r, dim = 1) /= 3) stop 231 + if (any(r /= (/ 0, 0, 0 /))) stop 232 + 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, mask = m) + if (size(r, dim = 1) /= 4) stop 241 + if (any(r /= (/ 0, 0, 0, 0 /))) stop 242 + end subroutine + subroutine check_lower_bounds() + real, allocatable :: a(:,:,:) + logical, allocatable :: m(:,:,:) + integer, allocatable :: r(:) + allocate(a(3:6,-1:2,4), m(3:6,-1:2,4)) + a(:,:,:) = reshape((/ real:: data64 /), shape(a)) + m = reshape(mask64, shape(m)) + r = minloc(a, mask = m) + if (size(r, dim = 1) /= 3) stop 251 + if (any(r /= (/ 2, 3, 1 /))) stop 252 + 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,3,3)) + ! Direct assignment + a(:,:,:) = reshape(data64(1:27), shape(a)) + a(1,1,:) = minloc(a, mask=a<8) + if (any(a(1,1,:) /= (/ 3, 2, 1 /))) stop 171 + a(:,:,:) = reshape(data64(2:28), shape(a)) + a(3,3,:) = minloc(a, mask=a<8) + if (any(a(3,3,:) /= (/ 2, 2, 1 /))) stop 172 + a(:,:,:) = reshape(data64(3:29), shape(a)) + a(1,:,1) = minloc(a, mask=a<8) + if (any(a(1,:,1) /= (/ 1, 2, 1 /))) stop 173 + a(:,:,:) = reshape(data64(5:31), shape(a)) + a(2,:,2) = minloc(a, mask=a<8) + if (any(a(2,:,2) /= (/ 2, 1, 1 /))) stop 174 + a(:,:,:) = reshape(data64(6:32), shape(a)) + a(3,:,3) = minloc(a, mask=a<8) + if (any(a(3,:,3) /= (/ 1, 1, 1 /))) stop 175 + a(:,:,:) = reshape(data64(7:33), shape(a)) + a(:,1,1) = minloc(a, mask=a<8) + if (any(a(:,1,1) /= (/ 3, 2, 2 /))) stop 176 + a(:,:,:) = reshape(data64(8:34), shape(a)) + a(:,3,3) = minloc(a, mask=a<8) + if (any(a(:,3,3) /= (/ 2, 2, 2 /))) stop 177 + ! Subroutine assignment + a(:,:,:) = reshape(data64(9:35), shape(a)) + call set(a(1,1,:), minloc(a, mask=a<8)) + if (any(a(1,1,:) /= (/ 1, 2, 2 /))) stop 181 + a(:,:,:) = reshape(data64(10:36), shape(a)) + call set(a(3,3,:), minloc(a, mask=a<8)) + if (any(a(3,3,:) /= (/ 3, 1, 2 /))) stop 182 + a(:,:,:) = reshape(data64(11:37), shape(a)) + call set(a(1,:,1), minloc(a, mask=a<8)) + if (any(a(1,:,1) /= (/ 2, 1, 2 /))) stop 183 + a(:,:,:) = reshape(data64(12:38), shape(a)) + call set(a(2,:,2), minloc(a, mask=a<8)) + if (any(a(2,:,2) /= (/ 1, 1, 2 /))) stop 184 + a(:,:,:) = reshape(data64(13:39), shape(a)) + call set(a(3,:,3), minloc(a, mask=a<8)) + if (any(a(3,:,3) /= (/ 3, 3, 1 /))) stop 185 + a(:,:,:) = reshape(data64(14:40), shape(a)) + call set(a(:,1,1), minloc(a, mask=a<8)) + if (any(a(:,1,1) /= (/ 2, 3, 1 /))) stop 186 + a(:,:,:) = reshape(data64(15:41), shape(a)) + call set(a(:,3,3), minloc(a, mask=a<8)) + if (any(a(:,3,3) /= (/ 1, 3, 1 /))) stop 187 + call set(a(1,:,:), minloc(a, dim=1)) + end subroutine check_dependencies +end program p