From patchwork Mon Oct 14 15:08:10 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 1997021 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=COw/Z/CD; 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 4XS0yv4ShSz1xvK for ; Tue, 15 Oct 2024 02:10:15 +1100 (AEDT) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id CA251385AE6D for ; Mon, 14 Oct 2024 15:10:13 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from smtp.smtpout.orange.fr (smtp-17.smtpout.orange.fr [80.12.242.17]) by sourceware.org (Postfix) with ESMTPS id 281293857003; Mon, 14 Oct 2024 15:08:30 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 281293857003 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 281293857003 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=80.12.242.17 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1728918516; cv=none; b=LYt+XXI+ZBUXPXpAiUBdjlqzqGPA4o7VrnSnThyiNBplMMEArOquhHuJ/YFgNzTo44jKCO6Q6+UyHBSRrfcvkK3KtMFouATgAWvie5QsLzyKvTjklf1yN5S0cmX45BpBN1gAmjwIwwpPc5YBJH8oooTEoz39fL6zb1gSnXv1ED8= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1728918516; c=relaxed/simple; bh=7BOJprU4UvoVnQ22a3pVnigObTyS3zXVHnGp1pP5U7M=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=e6bB2hnMY4ME/gzEOaXckAj1jtmrftKSKE3ZJG8P66pU0qtEnxUfWettCKe4MoaaSjiGCmoasUqQrwhh1Uf9xJxG5UbITH4gIS1Yp2eDfl1wIEVGq+GNvUAh/HWlw9fMGmTtxSkWhfx4nH8N10s/GiqE/p0PVE8pK+dwoLg8dgk= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id 0MgBtHlyUIPG80MgPtVhJc; Mon, 14 Oct 2024 17:08:29 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=orange.fr; s=t20230301; t=1728918509; bh=/HHymIFIaCvXSK7VmacVyUKfMIjNXCvfwedkCEw9Vt8=; h=From:To:Subject:Date:Message-ID:MIME-Version; b=COw/Z/CDYjNPgP/tIgNUlXnjHxMFTEA2Of3pUqRGC1P5Nxl+s3gBHAJeAIWvXjF0P 6zknG34uX5P8xW/RFfHCdHLZdAUGw47SpyR/ErnoppWussb0+S7zHG5li2Kbe8TdiM i5aVc9KNB1MdgoMk5EnnXg4TtdNDNJbjxAzLFFS0RXXcJqbt5wOR/w8bUoQC3IeX2/ 07Eic3++xzCpka7MMMW8SrLTBbNs5mVMVfyE8qW26+4wNZ0mxV4K+fV4N/ZGYJ3Fui c8GsjZloNonfHn3Sox7AlPFdAb+cWOSHlzv52rNBNBbYtbM+EZCnfxbbQpmSFKQ67H 1BxDvExsUAmgQ== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Mon, 14 Oct 2024 17:08:29 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin 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> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20241014150816.315478-1-morin-mikael@orange.fr> References: <20241014150816.315478-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 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 Checked on x86_64-pc-linux-gnu. OK for master? -- >8 -- Add the tests covering the cases for which the following patches will implement inline expansion of MINLOC and MAXLOC. Those are cases where the DIM argument is a constant value, and the ARRAY argument has rank greater than 1. PR fortran/90608 gcc/testsuite/ChangeLog: * gfortran.dg/ieee/maxloc_nan_2.f90: New test. * gfortran.dg/ieee/minloc_nan_2.f90: New test. * gfortran.dg/maxloc_with_dim_1.f90: New test. * gfortran.dg/maxloc_with_dim_and_mask_1.f90: New test. * gfortran.dg/minloc_with_dim_1.f90: New test. * gfortran.dg/minloc_with_dim_and_mask_1.f90: New test. --- .../gfortran.dg/ieee/maxloc_nan_2.f90 | 64 +++ .../gfortran.dg/ieee/minloc_nan_2.f90 | 64 +++ .../gfortran.dg/maxloc_with_dim_1.f90 | 201 ++++++++ .../maxloc_with_dim_and_mask_1.f90 | 452 ++++++++++++++++++ .../gfortran.dg/minloc_with_dim_1.f90 | 201 ++++++++ .../minloc_with_dim_and_mask_1.f90 | 452 ++++++++++++++++++ 6 files changed, 1434 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/ieee/maxloc_nan_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/ieee/minloc_nan_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/maxloc_with_dim_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/maxloc_with_dim_and_mask_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/minloc_with_dim_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/minloc_with_dim_and_mask_1.f90 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