From patchwork Fri Oct 4 07:54:37 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 1992647 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=netcologne.de header.i=@netcologne.de header.a=rsa-sha256 header.s=nc1116a header.b=KXYQSR2g; 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 4XKhh35L2vz1xsn for ; Fri, 4 Oct 2024 18:35:31 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id C9F593846053 for ; Fri, 4 Oct 2024 08:35:29 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from cc-smtpout2.netcologne.de (cc-smtpout2.netcologne.de [89.1.8.212]) by sourceware.org (Postfix) with ESMTPS id D9E62385DC1E; Fri, 4 Oct 2024 07:54:41 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org D9E62385DC1E Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=netcologne.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=netcologne.de ARC-Filter: OpenARC Filter v1.0.0 sourceware.org D9E62385DC1E Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=89.1.8.212 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1728028492; cv=none; b=VmupCALFnldtr5UHoZ/hnDQ/Yl2/OilTtij11q81ztDHzLeoVPTPfc37bdnBtmReBsngkvjtHj+KbTJTqtWzNEe478vicP9bVl5lvZYPPoZozz5uMIEmMnqi/lTpaCofKau4OeB0nmJvrD+8I1Z4lwPoQoayLJyMkppu3wSZr3g= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1728028492; c=relaxed/simple; bh=tL6HyRVPK1Nko0ThqElunpDVlEFz3LyDvIBcQ4gZXV0=; h=DKIM-Signature:Message-ID:Date:MIME-Version:To:From:Subject; b=Nv3O2j5JsQXwY5uF4HAoFzfj9TAfSEkj9p9KzhcONPdoEBaLzGnWDWXvD8LhjApS4RFuTa73jI0bhsNgu+u9Mzuq3jkD0tOxH9Z7SJZKFCvfRlLtFhvxtx8Mx6BZ01l0Oi6wKvjQ5JIJBds2Ug1TOMNJ8iTqrYHWNNn2by5vsoM= ARC-Authentication-Results: i=1; server2.sourceware.org Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 5526A1283C; Fri, 4 Oct 2024 09:54:40 +0200 (CEST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/simple; d=netcologne.de; s=nc1116a; t=1728028480; bh=tL6HyRVPK1Nko0ThqElunpDVlEFz3LyDvIBcQ4gZXV0=; h=Message-ID:Date:To:From:Subject:From; b=KXYQSR2g2riFQLGgjdPmSh9CNSGK8qrFd1n1gjznvNUh+IP9qFoWajfwK6rd0UR8u ua/U4Zp2jWBRCGd7/e1hzR0y5ehWMH20OX7aRG8aHLKa/gwp/jRNtlOsONe7HYIhP9 TZuznyv8lRa+WQB/EOaISXlQA4tdd6z92wAhtQzol2iOHKvsU1H8JEONYDA+umMQC3 mt7KhBLgsqx8zt+DInM1H1fd0G7ZERSWgqOlR0S2ESXnngDy5G8qv9QjSfS0Kq5C2e aUjdAFWQySiin3JUCJna/bUKvOlXJ45Ox7bF5IVh3bBNW38PL47AKje7/Zk+atMZiM mlUtm7V9k7zpA== Received: from [IPV6:2001:4dd7:cd5:0:bbd3:3a54:dab9:b708] (2001-4dd7-cd5-0-bbd3-3a54-dab9-b708.ipv6dyn.netcologne.de [IPv6:2001:4dd7:cd5:0:bbd3:3a54:dab9:b708]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA id 518B311DC0; Fri, 4 Oct 2024 09:54:37 +0200 (CEST) Message-ID: <535e8c0b-e637-4c2d-b188-0ae994b1648e@netcologne.de> Date: Fri, 4 Oct 2024 09:54:37 +0200 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Content-Language: en-US, de-DE To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] Implement maxloc and minloc for unsigned X-NetCologne-Spam: L X-Rspamd-Queue-Id: 518B311DC0 X-Spamd-Bar: / X-Rspamd-Action: no action X-Spam-Status: No, score=-11.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_SHORT, RCVD_IN_DNSWL_LOW, RCVD_IN_MSPIKE_H3, RCVD_IN_MSPIKE_WL, SPF_HELO_NONE, 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-Mailman-Approved-At: Fri, 04 Oct 2024 08:34:42 +0000 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 Hello world, please find attached the patch for implementing MAXLOC and MINLOC for unsigned. The patch is rather lengthy, but mostly due to combinatorial explosion with the different return values. Next time we update the ABI, we should treat MAXLOC and MINLOC like we already do for FINDLOC - have one version in the library, and convert in the front end when the user requests a different integer kind. This finishes the support of all reasonable intrinsics for UNSIGNED (or so I think - if anybody spots something reasonable, just let me know). The next step would then be ISO_C_BINDING; clean interfaces to C is one of the main reason why people want UNSIGNED in Fortran. Regression-tested. OK for trunk? Best regards Thomas gcc/fortran/ChangeLog: * check.cc (gfc_check_minloc_maxloc): Handle BT_UNSIGNED. * trans-intrinsic.cc (gfc_conv_intrinsic_minmaxloc): Likewise. * gfortran.texi: Document MAXLOC and MINLOC for UNSIGNED. libgfortran/ChangeLog: * Makefile.am: Add files for unsigned MINLOC and MAXLOC. * Makefile.in: Regenerated. * gfortran.map: Add files for unsigned MINLOC and MAXLOC. * generated/maxloc0_16_m1.c: New file. * generated/maxloc0_16_m16.c: New file. * generated/maxloc0_16_m2.c: New file. * generated/maxloc0_16_m4.c: New file. * generated/maxloc0_16_m8.c: New file. * generated/maxloc0_4_m1.c: New file. * generated/maxloc0_4_m16.c: New file. * generated/maxloc0_4_m2.c: New file. * generated/maxloc0_4_m4.c: New file. * generated/maxloc0_4_m8.c: New file. * generated/maxloc0_8_m1.c: New file. * generated/maxloc0_8_m16.c: New file. * generated/maxloc0_8_m2.c: New file. * generated/maxloc0_8_m4.c: New file. * generated/maxloc0_8_m8.c: New file. * generated/maxloc1_16_m1.c: New file. * generated/maxloc1_16_m2.c: New file. * generated/maxloc1_16_m4.c: New file. * generated/maxloc1_16_m8.c: New file. * generated/maxloc1_4_m1.c: New file. * generated/maxloc1_4_m16.c: New file. * generated/maxloc1_4_m2.c: New file. * generated/maxloc1_4_m4.c: New file. * generated/maxloc1_4_m8.c: New file. * generated/maxloc1_8_m1.c: New file. * generated/maxloc1_8_m16.c: New file. * generated/maxloc1_8_m2.c: New file. * generated/maxloc1_8_m4.c: New file. * generated/maxloc1_8_m8.c: New file. * generated/minloc0_16_m1.c: New file. * generated/minloc0_16_m16.c: New file. * generated/minloc0_16_m2.c: New file. * generated/minloc0_16_m4.c: New file. * generated/minloc0_16_m8.c: New file. * generated/minloc0_4_m1.c: New file. * generated/minloc0_4_m16.c: New file. * generated/minloc0_4_m2.c: New file. * generated/minloc0_4_m4.c: New file. * generated/minloc0_4_m8.c: New file. * generated/minloc0_8_m1.c: New file. * generated/minloc0_8_m16.c: New file. * generated/minloc0_8_m2.c: New file. * generated/minloc0_8_m4.c: New file. * generated/minloc0_8_m8.c: New file. * generated/minloc1_16_m1.c: New file. * generated/minloc1_16_m16.c: New file. * generated/minloc1_16_m2.c: New file. * generated/minloc1_16_m4.c: New file. * generated/minloc1_16_m8.c: New file. * generated/minloc1_4_m1.c: New file. * generated/minloc1_4_m16.c: New file. * generated/minloc1_4_m2.c: New file. * generated/minloc1_4_m4.c: New file. * generated/minloc1_4_m8.c: New file. * generated/minloc1_8_m1.c: New file. * generated/minloc1_8_m16.c: New file. * generated/minloc1_8_m2.c: New file. * generated/minloc1_8_m4.c: New file. * generated/minloc1_8_m8.c: New file. diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 9c0b72fa010..79e6668d0af 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -4219,7 +4219,17 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap) gfc_expr *a, *m, *d, *k, *b; a = ap->expr; - if (!int_or_real_or_char_check_f2003 (a, 0) || !array_check (a, 0)) + + if (flag_unsigned) + { + if (!int_or_real_or_char_or_unsigned_check_f2003 (a, 0)) + return false; + } + else + if (!int_or_real_or_char_check_f2003 (a, 0)) + return false; + + if (!array_check (a, 0)) return false; d = ap->next->expr; diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index e065e31aaf8..a282ae1c090 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -5637,6 +5637,21 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) arrayexpr->ts.kind); break; + case BT_UNSIGNED: + /* For MAXVAL, the minimum is zero, for MINVAL it is HUGE(). */ + if (op == GT_EXPR) + { + tmp = gfc_get_unsigned_type (arrayexpr->ts.kind); + tmp = build_int_cst (tmp, 0); + } + else + { + n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); + tmp = gfc_conv_mpz_unsigned_to_tree (gfc_unsigned_kinds[n].huge, + expr->ts.kind); + } + break; + default: gcc_unreachable (); } @@ -5644,8 +5659,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) /* We start with the most negative possible value for MAXLOC, and the most positive possible value for MINLOC. The most negative possible value is -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive - possible value is HUGE in both cases. */ - if (op == GT_EXPR) + possible value is HUGE in both cases. BT_UNSIGNED has already been dealt + with above. */ + if (op == GT_EXPR && expr->ts.type != BT_UNSIGNED) tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp); if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER) tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp, diff --git a/gcc/testsuite/gfortran.dg/unsigned_35.f90 b/gcc/testsuite/gfortran.dg/unsigned_35.f90 new file mode 100644 index 00000000000..9c94bfb12d4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/unsigned_35.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-options "-funsigned" } +program memain + implicit none + call test1 +contains + subroutine test1 + unsigned, dimension(3) :: v + integer :: t1, t2 + unsigned(2), dimension(3,3) :: w + integer, dimension(3,3) :: j + integer :: di + v = [1u, 2u, 4294967286u] + t1 = maxloc(v,dim=1) + if (t1 /= 3) error stop 1 + t2 = minloc(v,dim=1) + if (t2 /= 1) error stop 2 + call check_empty(0) + j = reshape([1,2,3,65534,5,1,65000,2,1],[3,3]) + w = uint(j,2) + if (any(maxloc(j,dim=1) /= int(maxloc(w,dim=1)))) error stop 5 + di = 2 + if (any(maxloc(j,dim=di) /= int(maxloc(w,dim=di)))) error stop 6 + end subroutine test1 + subroutine check_empty(n) + integer, intent(in) :: n + unsigned, dimension(n) :: empty + if (minloc(empty, dim=1) /= 0) error stop 3 + if (maxloc(empty, dim=1) /= 0) error stop 4 + end subroutine check_empty + subroutine test2 + integer :: i + unsigned, dimension(3), parameter :: v = [1u, 2u, 4294967286u] + integer, parameter :: t1 = maxloc(v,dim=1) + integer, parameter :: t2 = minloc(v,dim=1) + unsigned, parameter, dimension(2:1) :: empty = [(0u,i=2,1)] + integer, parameter :: t3 = minloc(empty,1) + integer, parameter :: t4 = maxloc(empty,1) + unsigned(2), parameter, dimension(2:1,2:1) :: e2 = reshape(empty,[0,0]) + integer, parameter, dimension(3,3) :: j = reshape([1,2,3,65534,5,1,65000,2,1],[3,3]) + integer, parameter, dimension(3) :: maxvj = maxloc(j,1), minvj=minloc(j,2) + unsigned, parameter, dimension(3,3) :: w = uint(j,2) + integer(2), parameter, dimension(3) :: maxvw = maxloc(w,1), minvw = minloc(w,2) + + if (t1 /= 3) error stop 11 + if (t2 /= 1) error stop 12 + if (t3 /= 0) error stop 13 + if (t4 /= 0) error stop 14 + if (any(maxvj /= maxvw)) error stop 15 + if (any(minvj /= minvw)) error stop 16 + end subroutine test2 +end program memain diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index 1564e2abcde..f58af5890d9 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -350,6 +350,21 @@ generated/maxloc0_16_i8.c \ generated/maxloc0_4_i16.c \ generated/maxloc0_8_i16.c \ generated/maxloc0_16_i16.c \ +generated/maxloc0_4_m1.c \ +generated/maxloc0_8_m1.c \ +generated/maxloc0_16_m1.c \ +generated/maxloc0_4_m2.c \ +generated/maxloc0_8_m2.c \ +generated/maxloc0_16_m2.c \ +generated/maxloc0_4_m4.c \ +generated/maxloc0_8_m4.c \ +generated/maxloc0_16_m4.c \ +generated/maxloc0_4_m8.c \ +generated/maxloc0_8_m8.c \ +generated/maxloc0_16_m8.c \ +generated/maxloc0_4_m16.c \ +generated/maxloc0_8_m16.c \ +generated/maxloc0_16_m16.c \ generated/maxloc0_4_r4.c \ generated/maxloc0_8_r4.c \ generated/maxloc0_16_r4.c \ @@ -384,11 +399,20 @@ generated/maxloc1_16_i2.c \ generated/maxloc1_4_i4.c \ generated/maxloc1_8_i4.c \ generated/maxloc1_16_i4.c \ -generated/maxloc1_4_i8.c \ -generated/maxloc1_8_i8.c \ -generated/maxloc1_16_i8.c \ -generated/maxloc1_4_i16.c \ -generated/maxloc1_8_i16.c \ +generated/maxloc1_4_m1.c \ +generated/maxloc1_8_m1.c \ +generated/maxloc1_16_m1.c \ +generated/maxloc1_4_m2.c \ +generated/maxloc1_8_m2.c \ +generated/maxloc1_16_m2.c \ +generated/maxloc1_4_m4.c \ +generated/maxloc1_8_m4.c \ +generated/maxloc1_16_m4.c \ +generated/maxloc1_4_m8.c \ +generated/maxloc1_8_m8.c \ +generated/maxloc1_16_m8.c \ +generated/maxloc1_4_m16.c \ +generated/maxloc1_8_m16.c \ generated/maxloc1_16_i16.c \ generated/maxloc1_4_r4.c \ generated/maxloc1_8_r4.c \ @@ -463,6 +487,21 @@ generated/minloc0_16_i8.c \ generated/minloc0_4_i16.c \ generated/minloc0_8_i16.c \ generated/minloc0_16_i16.c \ +generated/minloc0_4_m1.c \ +generated/minloc0_8_m1.c \ +generated/minloc0_16_m1.c \ +generated/minloc0_4_m2.c \ +generated/minloc0_8_m2.c \ +generated/minloc0_16_m2.c \ +generated/minloc0_4_m4.c \ +generated/minloc0_8_m4.c \ +generated/minloc0_16_m4.c \ +generated/minloc0_4_m8.c \ +generated/minloc0_8_m8.c \ +generated/minloc0_16_m8.c \ +generated/minloc0_4_m16.c \ +generated/minloc0_8_m16.c \ +generated/minloc0_16_m16.c \ generated/minloc0_4_r4.c \ generated/minloc0_8_r4.c \ generated/minloc0_16_r4.c \ @@ -503,6 +542,21 @@ generated/minloc1_16_i8.c \ generated/minloc1_4_i16.c \ generated/minloc1_8_i16.c \ generated/minloc1_16_i16.c \ +generated/minloc1_4_m1.c \ +generated/minloc1_8_m1.c \ +generated/minloc1_16_m1.c \ +generated/minloc1_4_m2.c \ +generated/minloc1_8_m2.c \ +generated/minloc1_16_m2.c \ +generated/minloc1_4_m4.c \ +generated/minloc1_8_m4.c \ +generated/minloc1_16_m4.c \ +generated/minloc1_4_m8.c \ +generated/minloc1_8_m8.c \ +generated/minloc1_16_m8.c \ +generated/minloc1_4_m16.c \ +generated/minloc1_8_m16.c \ +generated/minloc1_16_m16.c \ generated/minloc1_4_r4.c \ generated/minloc1_8_r4.c \ generated/minloc1_16_r4.c \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index d850c2ec314..f9a1864832d 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -245,29 +245,42 @@ am__objects_7 = generated/maxloc0_4_i1.lo generated/maxloc0_8_i1.lo \ generated/maxloc0_16_i4.lo generated/maxloc0_4_i8.lo \ generated/maxloc0_8_i8.lo generated/maxloc0_16_i8.lo \ generated/maxloc0_4_i16.lo generated/maxloc0_8_i16.lo \ - generated/maxloc0_16_i16.lo generated/maxloc0_4_r4.lo \ - generated/maxloc0_8_r4.lo generated/maxloc0_16_r4.lo \ - generated/maxloc0_4_r8.lo generated/maxloc0_8_r8.lo \ - generated/maxloc0_16_r8.lo generated/maxloc0_4_r10.lo \ - generated/maxloc0_8_r10.lo generated/maxloc0_16_r10.lo \ - generated/maxloc0_4_r16.lo generated/maxloc0_8_r16.lo \ - generated/maxloc0_16_r16.lo generated/maxloc0_4_r17.lo \ - generated/maxloc0_8_r17.lo generated/maxloc0_16_r17.lo + generated/maxloc0_16_i16.lo generated/maxloc0_4_m1.lo \ + generated/maxloc0_8_m1.lo generated/maxloc0_16_m1.lo \ + generated/maxloc0_4_m2.lo generated/maxloc0_8_m2.lo \ + generated/maxloc0_16_m2.lo generated/maxloc0_4_m4.lo \ + generated/maxloc0_8_m4.lo generated/maxloc0_16_m4.lo \ + generated/maxloc0_4_m8.lo generated/maxloc0_8_m8.lo \ + generated/maxloc0_16_m8.lo generated/maxloc0_4_m16.lo \ + generated/maxloc0_8_m16.lo generated/maxloc0_16_m16.lo \ + generated/maxloc0_4_r4.lo generated/maxloc0_8_r4.lo \ + generated/maxloc0_16_r4.lo generated/maxloc0_4_r8.lo \ + generated/maxloc0_8_r8.lo generated/maxloc0_16_r8.lo \ + generated/maxloc0_4_r10.lo generated/maxloc0_8_r10.lo \ + generated/maxloc0_16_r10.lo generated/maxloc0_4_r16.lo \ + generated/maxloc0_8_r16.lo generated/maxloc0_16_r16.lo \ + generated/maxloc0_4_r17.lo generated/maxloc0_8_r17.lo \ + generated/maxloc0_16_r17.lo am__objects_8 = generated/maxloc1_4_i1.lo generated/maxloc1_8_i1.lo \ generated/maxloc1_16_i1.lo generated/maxloc1_4_i2.lo \ generated/maxloc1_8_i2.lo generated/maxloc1_16_i2.lo \ generated/maxloc1_4_i4.lo generated/maxloc1_8_i4.lo \ - generated/maxloc1_16_i4.lo generated/maxloc1_4_i8.lo \ - generated/maxloc1_8_i8.lo generated/maxloc1_16_i8.lo \ - generated/maxloc1_4_i16.lo generated/maxloc1_8_i16.lo \ - generated/maxloc1_16_i16.lo generated/maxloc1_4_r4.lo \ - generated/maxloc1_8_r4.lo generated/maxloc1_16_r4.lo \ - generated/maxloc1_4_r8.lo generated/maxloc1_8_r8.lo \ - generated/maxloc1_16_r8.lo generated/maxloc1_4_r10.lo \ - generated/maxloc1_8_r10.lo generated/maxloc1_16_r10.lo \ - generated/maxloc1_4_r16.lo generated/maxloc1_8_r16.lo \ - generated/maxloc1_16_r16.lo generated/maxloc1_4_r17.lo \ - generated/maxloc1_8_r17.lo generated/maxloc1_16_r17.lo + generated/maxloc1_16_i4.lo generated/maxloc1_4_m1.lo \ + generated/maxloc1_8_m1.lo generated/maxloc1_16_m1.lo \ + generated/maxloc1_4_m2.lo generated/maxloc1_8_m2.lo \ + generated/maxloc1_16_m2.lo generated/maxloc1_4_m4.lo \ + generated/maxloc1_8_m4.lo generated/maxloc1_16_m4.lo \ + generated/maxloc1_4_m8.lo generated/maxloc1_8_m8.lo \ + generated/maxloc1_16_m8.lo generated/maxloc1_4_m16.lo \ + generated/maxloc1_8_m16.lo generated/maxloc1_16_i16.lo \ + generated/maxloc1_4_r4.lo generated/maxloc1_8_r4.lo \ + generated/maxloc1_16_r4.lo generated/maxloc1_4_r8.lo \ + generated/maxloc1_8_r8.lo generated/maxloc1_16_r8.lo \ + generated/maxloc1_4_r10.lo generated/maxloc1_8_r10.lo \ + generated/maxloc1_16_r10.lo generated/maxloc1_4_r16.lo \ + generated/maxloc1_8_r16.lo generated/maxloc1_16_r16.lo \ + generated/maxloc1_4_r17.lo generated/maxloc1_8_r17.lo \ + generated/maxloc1_16_r17.lo am__objects_9 = generated/maxval_i1.lo generated/maxval_i2.lo \ generated/maxval_i4.lo generated/maxval_i8.lo \ generated/maxval_i16.lo generated/maxval_m1.lo \ @@ -283,14 +296,22 @@ am__objects_10 = generated/minloc0_4_i1.lo generated/minloc0_8_i1.lo \ generated/minloc0_16_i4.lo generated/minloc0_4_i8.lo \ generated/minloc0_8_i8.lo generated/minloc0_16_i8.lo \ generated/minloc0_4_i16.lo generated/minloc0_8_i16.lo \ - generated/minloc0_16_i16.lo generated/minloc0_4_r4.lo \ - generated/minloc0_8_r4.lo generated/minloc0_16_r4.lo \ - generated/minloc0_4_r8.lo generated/minloc0_8_r8.lo \ - generated/minloc0_16_r8.lo generated/minloc0_4_r10.lo \ - generated/minloc0_8_r10.lo generated/minloc0_16_r10.lo \ - generated/minloc0_4_r16.lo generated/minloc0_8_r16.lo \ - generated/minloc0_16_r16.lo generated/minloc0_4_r17.lo \ - generated/minloc0_8_r17.lo generated/minloc0_16_r17.lo + generated/minloc0_16_i16.lo generated/minloc0_4_m1.lo \ + generated/minloc0_8_m1.lo generated/minloc0_16_m1.lo \ + generated/minloc0_4_m2.lo generated/minloc0_8_m2.lo \ + generated/minloc0_16_m2.lo generated/minloc0_4_m4.lo \ + generated/minloc0_8_m4.lo generated/minloc0_16_m4.lo \ + generated/minloc0_4_m8.lo generated/minloc0_8_m8.lo \ + generated/minloc0_16_m8.lo generated/minloc0_4_m16.lo \ + generated/minloc0_8_m16.lo generated/minloc0_16_m16.lo \ + generated/minloc0_4_r4.lo generated/minloc0_8_r4.lo \ + generated/minloc0_16_r4.lo generated/minloc0_4_r8.lo \ + generated/minloc0_8_r8.lo generated/minloc0_16_r8.lo \ + generated/minloc0_4_r10.lo generated/minloc0_8_r10.lo \ + generated/minloc0_16_r10.lo generated/minloc0_4_r16.lo \ + generated/minloc0_8_r16.lo generated/minloc0_16_r16.lo \ + generated/minloc0_4_r17.lo generated/minloc0_8_r17.lo \ + generated/minloc0_16_r17.lo am__objects_11 = generated/minloc1_4_i1.lo generated/minloc1_8_i1.lo \ generated/minloc1_16_i1.lo generated/minloc1_4_i2.lo \ generated/minloc1_8_i2.lo generated/minloc1_16_i2.lo \ @@ -298,14 +319,22 @@ am__objects_11 = generated/minloc1_4_i1.lo generated/minloc1_8_i1.lo \ generated/minloc1_16_i4.lo generated/minloc1_4_i8.lo \ generated/minloc1_8_i8.lo generated/minloc1_16_i8.lo \ generated/minloc1_4_i16.lo generated/minloc1_8_i16.lo \ - generated/minloc1_16_i16.lo generated/minloc1_4_r4.lo \ - generated/minloc1_8_r4.lo generated/minloc1_16_r4.lo \ - generated/minloc1_4_r8.lo generated/minloc1_8_r8.lo \ - generated/minloc1_16_r8.lo generated/minloc1_4_r10.lo \ - generated/minloc1_8_r10.lo generated/minloc1_16_r10.lo \ - generated/minloc1_4_r16.lo generated/minloc1_8_r16.lo \ - generated/minloc1_16_r16.lo generated/minloc1_4_r17.lo \ - generated/minloc1_8_r17.lo generated/minloc1_16_r17.lo + generated/minloc1_16_i16.lo generated/minloc1_4_m1.lo \ + generated/minloc1_8_m1.lo generated/minloc1_16_m1.lo \ + generated/minloc1_4_m2.lo generated/minloc1_8_m2.lo \ + generated/minloc1_16_m2.lo generated/minloc1_4_m4.lo \ + generated/minloc1_8_m4.lo generated/minloc1_16_m4.lo \ + generated/minloc1_4_m8.lo generated/minloc1_8_m8.lo \ + generated/minloc1_16_m8.lo generated/minloc1_4_m16.lo \ + generated/minloc1_8_m16.lo generated/minloc1_16_m16.lo \ + generated/minloc1_4_r4.lo generated/minloc1_8_r4.lo \ + generated/minloc1_16_r4.lo generated/minloc1_4_r8.lo \ + generated/minloc1_8_r8.lo generated/minloc1_16_r8.lo \ + generated/minloc1_4_r10.lo generated/minloc1_8_r10.lo \ + generated/minloc1_16_r10.lo generated/minloc1_4_r16.lo \ + generated/minloc1_8_r16.lo generated/minloc1_16_r16.lo \ + generated/minloc1_4_r17.lo generated/minloc1_8_r17.lo \ + generated/minloc1_16_r17.lo am__objects_12 = generated/minval_i1.lo generated/minval_i2.lo \ generated/minval_i4.lo generated/minval_i8.lo \ generated/minval_i16.lo generated/minval_m1.lo \ @@ -1114,6 +1143,21 @@ generated/maxloc0_16_i8.c \ generated/maxloc0_4_i16.c \ generated/maxloc0_8_i16.c \ generated/maxloc0_16_i16.c \ +generated/maxloc0_4_m1.c \ +generated/maxloc0_8_m1.c \ +generated/maxloc0_16_m1.c \ +generated/maxloc0_4_m2.c \ +generated/maxloc0_8_m2.c \ +generated/maxloc0_16_m2.c \ +generated/maxloc0_4_m4.c \ +generated/maxloc0_8_m4.c \ +generated/maxloc0_16_m4.c \ +generated/maxloc0_4_m8.c \ +generated/maxloc0_8_m8.c \ +generated/maxloc0_16_m8.c \ +generated/maxloc0_4_m16.c \ +generated/maxloc0_8_m16.c \ +generated/maxloc0_16_m16.c \ generated/maxloc0_4_r4.c \ generated/maxloc0_8_r4.c \ generated/maxloc0_16_r4.c \ @@ -1148,11 +1192,20 @@ generated/maxloc1_16_i2.c \ generated/maxloc1_4_i4.c \ generated/maxloc1_8_i4.c \ generated/maxloc1_16_i4.c \ -generated/maxloc1_4_i8.c \ -generated/maxloc1_8_i8.c \ -generated/maxloc1_16_i8.c \ -generated/maxloc1_4_i16.c \ -generated/maxloc1_8_i16.c \ +generated/maxloc1_4_m1.c \ +generated/maxloc1_8_m1.c \ +generated/maxloc1_16_m1.c \ +generated/maxloc1_4_m2.c \ +generated/maxloc1_8_m2.c \ +generated/maxloc1_16_m2.c \ +generated/maxloc1_4_m4.c \ +generated/maxloc1_8_m4.c \ +generated/maxloc1_16_m4.c \ +generated/maxloc1_4_m8.c \ +generated/maxloc1_8_m8.c \ +generated/maxloc1_16_m8.c \ +generated/maxloc1_4_m16.c \ +generated/maxloc1_8_m16.c \ generated/maxloc1_16_i16.c \ generated/maxloc1_4_r4.c \ generated/maxloc1_8_r4.c \ @@ -1227,6 +1280,21 @@ generated/minloc0_16_i8.c \ generated/minloc0_4_i16.c \ generated/minloc0_8_i16.c \ generated/minloc0_16_i16.c \ +generated/minloc0_4_m1.c \ +generated/minloc0_8_m1.c \ +generated/minloc0_16_m1.c \ +generated/minloc0_4_m2.c \ +generated/minloc0_8_m2.c \ +generated/minloc0_16_m2.c \ +generated/minloc0_4_m4.c \ +generated/minloc0_8_m4.c \ +generated/minloc0_16_m4.c \ +generated/minloc0_4_m8.c \ +generated/minloc0_8_m8.c \ +generated/minloc0_16_m8.c \ +generated/minloc0_4_m16.c \ +generated/minloc0_8_m16.c \ +generated/minloc0_16_m16.c \ generated/minloc0_4_r4.c \ generated/minloc0_8_r4.c \ generated/minloc0_16_r4.c \ @@ -1267,6 +1335,21 @@ generated/minloc1_16_i8.c \ generated/minloc1_4_i16.c \ generated/minloc1_8_i16.c \ generated/minloc1_16_i16.c \ +generated/minloc1_4_m1.c \ +generated/minloc1_8_m1.c \ +generated/minloc1_16_m1.c \ +generated/minloc1_4_m2.c \ +generated/minloc1_8_m2.c \ +generated/minloc1_16_m2.c \ +generated/minloc1_4_m4.c \ +generated/minloc1_8_m4.c \ +generated/minloc1_16_m4.c \ +generated/minloc1_4_m8.c \ +generated/minloc1_8_m8.c \ +generated/minloc1_16_m8.c \ +generated/minloc1_4_m16.c \ +generated/minloc1_8_m16.c \ +generated/minloc1_16_m16.c \ generated/minloc1_4_r4.c \ generated/minloc1_8_r4.c \ generated/minloc1_16_r4.c \ @@ -2110,6 +2193,36 @@ generated/maxloc0_8_i16.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/maxloc0_16_i16.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_4_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_8_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_16_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_4_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_8_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_16_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_4_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_8_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_16_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_4_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_8_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_16_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_4_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_8_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc0_16_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) generated/maxloc0_4_r4.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/maxloc0_8_r4.lo: generated/$(am__dirstamp) \ @@ -2158,15 +2271,33 @@ generated/maxloc1_8_i4.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/maxloc1_16_i4.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) -generated/maxloc1_4_i8.lo: generated/$(am__dirstamp) \ +generated/maxloc1_4_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc1_8_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc1_16_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc1_4_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc1_8_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc1_16_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc1_4_m4.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) -generated/maxloc1_8_i8.lo: generated/$(am__dirstamp) \ +generated/maxloc1_8_m4.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) -generated/maxloc1_16_i8.lo: generated/$(am__dirstamp) \ +generated/maxloc1_16_m4.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) -generated/maxloc1_4_i16.lo: generated/$(am__dirstamp) \ +generated/maxloc1_4_m8.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) -generated/maxloc1_8_i16.lo: generated/$(am__dirstamp) \ +generated/maxloc1_8_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc1_16_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc1_4_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/maxloc1_8_m16.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/maxloc1_16_i16.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) @@ -2260,6 +2391,36 @@ generated/minloc0_8_i16.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/minloc0_16_i16.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_4_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_8_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_16_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_4_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_8_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_16_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_4_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_8_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_16_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_4_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_8_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_16_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_4_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_8_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc0_16_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) generated/minloc0_4_r4.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/minloc0_8_r4.lo: generated/$(am__dirstamp) \ @@ -2320,6 +2481,36 @@ generated/minloc1_8_i16.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/minloc1_16_i16.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_4_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_8_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_16_m1.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_4_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_8_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_16_m2.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_4_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_8_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_16_m4.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_4_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_8_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_16_m8.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_4_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_8_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) +generated/minloc1_16_m16.lo: generated/$(am__dirstamp) \ + generated/$(DEPDIR)/$(am__dirstamp) generated/minloc1_4_r4.lo: generated/$(am__dirstamp) \ generated/$(DEPDIR)/$(am__dirstamp) generated/minloc1_8_r4.lo: generated/$(am__dirstamp) \ @@ -3864,6 +4055,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_16_r17.Plo@am__quote@ @@ -3876,6 +4072,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_4_r17.Plo@am__quote@ @@ -3888,6 +4089,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc0_8_r17.Plo@am__quote@ @@ -3899,7 +4105,10 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_i16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_i4.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_r17.Plo@am__quote@ @@ -3908,10 +4117,13 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_s1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_16_s4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_i1.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_i16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_i4.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_r17.Plo@am__quote@ @@ -3920,10 +4132,13 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_s1.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_4_s4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_i1.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_i16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_i4.Plo@am__quote@ -@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/maxloc1_8_r17.Plo@am__quote@ @@ -3961,6 +4176,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_16_r17.Plo@am__quote@ @@ -3973,6 +4193,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_4_r17.Plo@am__quote@ @@ -3985,6 +4210,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc0_8_r17.Plo@am__quote@ @@ -3997,6 +4227,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_16_r17.Plo@am__quote@ @@ -4009,6 +4244,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_4_r17.Plo@am__quote@ @@ -4021,6 +4261,11 @@ distclean-compile: @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_i2.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_i4.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_i8.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_m1.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_m16.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_m2.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_m4.Plo@am__quote@ +@AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_m8.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_r10.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_r16.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@generated/$(DEPDIR)/minloc1_8_r17.Plo@am__quote@ diff --git a/libgfortran/generated/maxloc0_16_m1.c b/libgfortran/generated/maxloc0_16_m1.c new file mode 100644 index 00000000000..339b7960c8c --- /dev/null +++ b/libgfortran/generated/maxloc0_16_m1.c @@ -0,0 +1,408 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_16_m1); + +void +maxloc0_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_1 *base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_1 maxval; +#if defined(GFC_UINTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_16_m1 (gfc_array_i16 * const restrict, + gfc_array_m1 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_16_m1); + +void +mmaxloc0_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + const GFC_UINTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_16_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_1 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_m1 (gfc_array_i16 * const restrict, + gfc_array_m1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_16_m1); + +void +smaxloc0_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (mask == NULL || *mask) + { + maxloc0_16_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_16_m16); + +void +maxloc0_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_16 *base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_16 maxval; +#if defined(GFC_UINTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_16_INFINITY) + maxval = -GFC_UINTEGER_16_INFINITY; +#else + maxval = -GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_16_m16 (gfc_array_i16 * const restrict, + gfc_array_m16 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_16_m16); + +void +mmaxloc0_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + const GFC_UINTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_16_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_16 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_16_INFINITY) + maxval = -GFC_UINTEGER_16_INFINITY; +#else + maxval = -GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_m16 (gfc_array_i16 * const restrict, + gfc_array_m16 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_16_m16); + +void +smaxloc0_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (mask == NULL || *mask) + { + maxloc0_16_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_16_m2); + +void +maxloc0_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_2 *base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_2 maxval; +#if defined(GFC_UINTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_16_m2 (gfc_array_i16 * const restrict, + gfc_array_m2 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_16_m2); + +void +mmaxloc0_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + const GFC_UINTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_16_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_2 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_m2 (gfc_array_i16 * const restrict, + gfc_array_m2 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_16_m2); + +void +smaxloc0_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (mask == NULL || *mask) + { + maxloc0_16_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_16_m4); + +void +maxloc0_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_4 *base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_4 maxval; +#if defined(GFC_UINTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_16_m4 (gfc_array_i16 * const restrict, + gfc_array_m4 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_16_m4); + +void +mmaxloc0_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + const GFC_UINTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_16_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_4 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_m4 (gfc_array_i16 * const restrict, + gfc_array_m4 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_16_m4); + +void +smaxloc0_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (mask == NULL || *mask) + { + maxloc0_16_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void maxloc0_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_16_m8); + +void +maxloc0_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_8 *base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_8 maxval; +#if defined(GFC_UINTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_16_m8 (gfc_array_i16 * const restrict, + gfc_array_m8 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_16_m8); + +void +mmaxloc0_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + const GFC_UINTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_16_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_8 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_16_m8 (gfc_array_i16 * const restrict, + gfc_array_m8 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_16_m8); + +void +smaxloc0_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (mask == NULL || *mask) + { + maxloc0_16_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_4_m1); + +void +maxloc0_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_1 *base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_1 maxval; +#if defined(GFC_UINTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_4_m1 (gfc_array_i4 * const restrict, + gfc_array_m1 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_4_m1); + +void +mmaxloc0_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + const GFC_UINTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_4_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_1 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_m1 (gfc_array_i4 * const restrict, + gfc_array_m1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_4_m1); + +void +smaxloc0_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (mask == NULL || *mask) + { + maxloc0_4_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_4_m16); + +void +maxloc0_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_16 *base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_16 maxval; +#if defined(GFC_UINTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_16_INFINITY) + maxval = -GFC_UINTEGER_16_INFINITY; +#else + maxval = -GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_4_m16 (gfc_array_i4 * const restrict, + gfc_array_m16 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_4_m16); + +void +mmaxloc0_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + const GFC_UINTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_4_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_16 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_16_INFINITY) + maxval = -GFC_UINTEGER_16_INFINITY; +#else + maxval = -GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_m16 (gfc_array_i4 * const restrict, + gfc_array_m16 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_4_m16); + +void +smaxloc0_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (mask == NULL || *mask) + { + maxloc0_4_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_4_m2); + +void +maxloc0_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_2 *base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_2 maxval; +#if defined(GFC_UINTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_4_m2 (gfc_array_i4 * const restrict, + gfc_array_m2 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_4_m2); + +void +mmaxloc0_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + const GFC_UINTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_4_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_2 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_m2 (gfc_array_i4 * const restrict, + gfc_array_m2 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_4_m2); + +void +smaxloc0_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (mask == NULL || *mask) + { + maxloc0_4_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_4_m4); + +void +maxloc0_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_4 *base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_4 maxval; +#if defined(GFC_UINTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_4_m4 (gfc_array_i4 * const restrict, + gfc_array_m4 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_4_m4); + +void +mmaxloc0_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + const GFC_UINTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_4_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_4 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_m4 (gfc_array_i4 * const restrict, + gfc_array_m4 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_4_m4); + +void +smaxloc0_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (mask == NULL || *mask) + { + maxloc0_4_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_4) + + +extern void maxloc0_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_4_m8); + +void +maxloc0_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_8 *base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_8 maxval; +#if defined(GFC_UINTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_4_m8 (gfc_array_i4 * const restrict, + gfc_array_m8 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_4_m8); + +void +mmaxloc0_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + const GFC_UINTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_4_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_8 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_4_m8 (gfc_array_i4 * const restrict, + gfc_array_m8 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_4_m8); + +void +smaxloc0_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (mask == NULL || *mask) + { + maxloc0_4_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_8_m1); + +void +maxloc0_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_1 *base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_1 maxval; +#if defined(GFC_UINTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_8_m1 (gfc_array_i8 * const restrict, + gfc_array_m1 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_8_m1); + +void +mmaxloc0_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + const GFC_UINTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_8_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_1 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_m1 (gfc_array_i8 * const restrict, + gfc_array_m1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_8_m1); + +void +smaxloc0_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (mask == NULL || *mask) + { + maxloc0_8_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_8_m16); + +void +maxloc0_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_16 *base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_16 maxval; +#if defined(GFC_UINTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_16_INFINITY) + maxval = -GFC_UINTEGER_16_INFINITY; +#else + maxval = -GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_8_m16 (gfc_array_i8 * const restrict, + gfc_array_m16 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_8_m16); + +void +mmaxloc0_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + const GFC_UINTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_8_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_16 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_16_INFINITY) + maxval = -GFC_UINTEGER_16_INFINITY; +#else + maxval = -GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_m16 (gfc_array_i8 * const restrict, + gfc_array_m16 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_8_m16); + +void +smaxloc0_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (mask == NULL || *mask) + { + maxloc0_8_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_8_m2); + +void +maxloc0_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_2 *base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_2 maxval; +#if defined(GFC_UINTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_8_m2 (gfc_array_i8 * const restrict, + gfc_array_m2 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_8_m2); + +void +mmaxloc0_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + const GFC_UINTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_8_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_2 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_m2 (gfc_array_i8 * const restrict, + gfc_array_m2 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_8_m2); + +void +smaxloc0_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (mask == NULL || *mask) + { + maxloc0_8_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_8_m4); + +void +maxloc0_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_4 *base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_4 maxval; +#if defined(GFC_UINTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_8_m4 (gfc_array_i8 * const restrict, + gfc_array_m4 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_8_m4); + +void +mmaxloc0_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + const GFC_UINTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_8_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_4 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_m4 (gfc_array_i8 * const restrict, + gfc_array_m4 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_8_m4); + +void +smaxloc0_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (mask == NULL || *mask) + { + maxloc0_8_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void maxloc0_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4); +export_proto(maxloc0_8_m8); + +void +maxloc0_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_8 *base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_8 maxval; +#if defined(GFC_UINTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base >= maxval) + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base >= maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mmaxloc0_8_m8 (gfc_array_i8 * const restrict, + gfc_array_m8 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mmaxloc0_8_m8); + +void +mmaxloc0_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + const GFC_UINTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + maxloc0_8_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_8 maxval; + int fast = 0; + +#if defined(GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base >= maxval) +#endif + { + fast = 1; + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (*mbase && *base >= maxval) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (*mbase && unlikely (*base > maxval)) + { + maxval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + + +extern void smaxloc0_8_m8 (gfc_array_i8 * const restrict, + gfc_array_m8 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(smaxloc0_8_m8); + +void +smaxloc0_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (mask == NULL || *mask) + { + maxloc0_8_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MAXLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_16_m1 (gfc_array_i16 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_16_m1); + +void +maxloc1_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_1 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_1 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_UINTEGER_1 maxval; +#if defined (GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_1_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_m1 (gfc_array_i16 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_16_m1); + +void +mmaxloc1_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + const GFC_UINTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_16_m1 (retarray, array, pdim, back); +#else + maxloc1_16_m1 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_1 maxval; +#if defined (GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif +#if defined (GFC_UINTEGER_1_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_16_m1 (gfc_array_i16 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_16_m1); + +void +smaxloc1_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_16_m1 (retarray, array, pdim, back); +#else + maxloc1_16_m1 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_m2.c b/libgfortran/generated/maxloc1_16_m2.c new file mode 100644 index 00000000000..8b49e3f1027 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_m2.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_16) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_16_m2 (gfc_array_i16 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_16_m2); + +void +maxloc1_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_2 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_2 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_UINTEGER_2 maxval; +#if defined (GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_2_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_m2 (gfc_array_i16 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_16_m2); + +void +mmaxloc1_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + const GFC_UINTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_16_m2 (retarray, array, pdim, back); +#else + maxloc1_16_m2 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_2 maxval; +#if defined (GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif +#if defined (GFC_UINTEGER_2_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_16_m2 (gfc_array_i16 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_16_m2); + +void +smaxloc1_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_16_m2 (retarray, array, pdim, back); +#else + maxloc1_16_m2 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_m4.c b/libgfortran/generated/maxloc1_16_m4.c new file mode 100644 index 00000000000..fad48cf145b --- /dev/null +++ b/libgfortran/generated/maxloc1_16_m4.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_16_m4 (gfc_array_i16 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_16_m4); + +void +maxloc1_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_4 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_4 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_UINTEGER_4 maxval; +#if defined (GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_4_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_m4 (gfc_array_i16 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_16_m4); + +void +mmaxloc1_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + const GFC_UINTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_16_m4 (retarray, array, pdim, back); +#else + maxloc1_16_m4 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_4 maxval; +#if defined (GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif +#if defined (GFC_UINTEGER_4_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_16_m4 (gfc_array_i16 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_16_m4); + +void +smaxloc1_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_16_m4 (retarray, array, pdim, back); +#else + maxloc1_16_m4 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_16_m8.c b/libgfortran/generated/maxloc1_16_m8.c new file mode 100644 index 00000000000..4b6527435d0 --- /dev/null +++ b/libgfortran/generated/maxloc1_16_m8.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_16) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_16_m8 (gfc_array_i16 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_16_m8); + +void +maxloc1_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_8 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_8 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_UINTEGER_8 maxval; +#if defined (GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_8_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_16_m8 (gfc_array_i16 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_16_m8); + +void +mmaxloc1_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + const GFC_UINTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_16_m8 (retarray, array, pdim, back); +#else + maxloc1_16_m8 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_8 maxval; +#if defined (GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif +#if defined (GFC_UINTEGER_8_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_16_m8 (gfc_array_i16 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_16_m8); + +void +smaxloc1_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_16_m8 (retarray, array, pdim, back); +#else + maxloc1_16_m8 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_m1.c b/libgfortran/generated/maxloc1_4_m1.c new file mode 100644 index 00000000000..a9c78cf2c20 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_m1.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_4_m1 (gfc_array_i4 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_4_m1); + +void +maxloc1_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_1 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_1 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_UINTEGER_1 maxval; +#if defined (GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_1_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_m1 (gfc_array_i4 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_4_m1); + +void +mmaxloc1_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_UINTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_4_m1 (retarray, array, pdim, back); +#else + maxloc1_4_m1 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_1 maxval; +#if defined (GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif +#if defined (GFC_UINTEGER_1_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_4_m1 (gfc_array_i4 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_4_m1); + +void +smaxloc1_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_4_m1 (retarray, array, pdim, back); +#else + maxloc1_4_m1 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_m16.c b/libgfortran/generated/maxloc1_4_m16.c new file mode 100644 index 00000000000..4091d7ef625 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_m16.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_4) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_4_m16 (gfc_array_i4 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_4_m16); + +void +maxloc1_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_16 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_16 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_UINTEGER_16 maxval; +#if defined (GFC_UINTEGER_16_INFINITY) + maxval = -GFC_UINTEGER_16_INFINITY; +#else + maxval = -GFC_UINTEGER_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_16_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_m16 (gfc_array_i4 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_4_m16); + +void +mmaxloc1_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_UINTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_4_m16 (retarray, array, pdim, back); +#else + maxloc1_4_m16 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_16 maxval; +#if defined (GFC_UINTEGER_16_INFINITY) + maxval = -GFC_UINTEGER_16_INFINITY; +#else + maxval = -GFC_UINTEGER_16_HUGE; +#endif +#if defined (GFC_UINTEGER_16_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_4_m16 (gfc_array_i4 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_4_m16); + +void +smaxloc1_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_4_m16 (retarray, array, pdim, back); +#else + maxloc1_4_m16 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_m2.c b/libgfortran/generated/maxloc1_4_m2.c new file mode 100644 index 00000000000..db8f61ecd69 --- /dev/null +++ b/libgfortran/generated/maxloc1_4_m2.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_4) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_4_m2 (gfc_array_i4 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_4_m2); + +void +maxloc1_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_2 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_2 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_UINTEGER_2 maxval; +#if defined (GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_2_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_m2 (gfc_array_i4 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_4_m2); + +void +mmaxloc1_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_UINTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_4_m2 (retarray, array, pdim, back); +#else + maxloc1_4_m2 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_2 maxval; +#if defined (GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif +#if defined (GFC_UINTEGER_2_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_4_m2 (gfc_array_i4 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_4_m2); + +void +smaxloc1_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_4_m2 (retarray, array, pdim, back); +#else + maxloc1_4_m2 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_m4.c b/libgfortran/generated/maxloc1_4_m4.c new file mode 100644 index 00000000000..90ac6f9a33f --- /dev/null +++ b/libgfortran/generated/maxloc1_4_m4.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_4_m4 (gfc_array_i4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_4_m4); + +void +maxloc1_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_4 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_UINTEGER_4 maxval; +#if defined (GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_4_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_m4 (gfc_array_i4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_4_m4); + +void +mmaxloc1_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_UINTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_4_m4 (retarray, array, pdim, back); +#else + maxloc1_4_m4 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_4 maxval; +#if defined (GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif +#if defined (GFC_UINTEGER_4_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_4_m4 (gfc_array_i4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_4_m4); + +void +smaxloc1_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_4_m4 (retarray, array, pdim, back); +#else + maxloc1_4_m4 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_4_m8.c b/libgfortran/generated/maxloc1_4_m8.c new file mode 100644 index 00000000000..9562cba250f --- /dev/null +++ b/libgfortran/generated/maxloc1_4_m8.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_4) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_4_m8 (gfc_array_i4 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_4_m8); + +void +maxloc1_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_8 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_8 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_UINTEGER_8 maxval; +#if defined (GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_8_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_4_m8 (gfc_array_i4 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_4_m8); + +void +mmaxloc1_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_UINTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_4_m8 (retarray, array, pdim, back); +#else + maxloc1_4_m8 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_8 maxval; +#if defined (GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif +#if defined (GFC_UINTEGER_8_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_4_m8 (gfc_array_i4 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_4_m8); + +void +smaxloc1_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_4_m8 (retarray, array, pdim, back); +#else + maxloc1_4_m8 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_m1.c b/libgfortran/generated/maxloc1_8_m1.c new file mode 100644 index 00000000000..8b42a6a5d93 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_m1.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_8_m1 (gfc_array_i8 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_8_m1); + +void +maxloc1_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_1 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_1 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_UINTEGER_1 maxval; +#if defined (GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_1_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_m1 (gfc_array_i8 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_8_m1); + +void +mmaxloc1_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + const GFC_UINTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_8_m1 (retarray, array, pdim, back); +#else + maxloc1_8_m1 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_1 maxval; +#if defined (GFC_UINTEGER_1_INFINITY) + maxval = -GFC_UINTEGER_1_INFINITY; +#else + maxval = -GFC_UINTEGER_1_HUGE; +#endif +#if defined (GFC_UINTEGER_1_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_8_m1 (gfc_array_i8 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_8_m1); + +void +smaxloc1_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_8_m1 (retarray, array, pdim, back); +#else + maxloc1_8_m1 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_m16.c b/libgfortran/generated/maxloc1_8_m16.c new file mode 100644 index 00000000000..4fc2bed0817 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_m16.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_8) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_8_m16 (gfc_array_i8 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_8_m16); + +void +maxloc1_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_16 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_16 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_UINTEGER_16 maxval; +#if defined (GFC_UINTEGER_16_INFINITY) + maxval = -GFC_UINTEGER_16_INFINITY; +#else + maxval = -GFC_UINTEGER_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_16_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_m16 (gfc_array_i8 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_8_m16); + +void +mmaxloc1_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + const GFC_UINTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_8_m16 (retarray, array, pdim, back); +#else + maxloc1_8_m16 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_16 maxval; +#if defined (GFC_UINTEGER_16_INFINITY) + maxval = -GFC_UINTEGER_16_INFINITY; +#else + maxval = -GFC_UINTEGER_16_HUGE; +#endif +#if defined (GFC_UINTEGER_16_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_8_m16 (gfc_array_i8 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_8_m16); + +void +smaxloc1_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_8_m16 (retarray, array, pdim, back); +#else + maxloc1_8_m16 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_m2.c b/libgfortran/generated/maxloc1_8_m2.c new file mode 100644 index 00000000000..48225b662a7 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_m2.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_8) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_8_m2 (gfc_array_i8 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_8_m2); + +void +maxloc1_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_2 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_2 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_UINTEGER_2 maxval; +#if defined (GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_2_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_m2 (gfc_array_i8 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_8_m2); + +void +mmaxloc1_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + const GFC_UINTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_8_m2 (retarray, array, pdim, back); +#else + maxloc1_8_m2 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_2 maxval; +#if defined (GFC_UINTEGER_2_INFINITY) + maxval = -GFC_UINTEGER_2_INFINITY; +#else + maxval = -GFC_UINTEGER_2_HUGE; +#endif +#if defined (GFC_UINTEGER_2_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_8_m2 (gfc_array_i8 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_8_m2); + +void +smaxloc1_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_8_m2 (retarray, array, pdim, back); +#else + maxloc1_8_m2 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_m4.c b/libgfortran/generated/maxloc1_8_m4.c new file mode 100644 index 00000000000..9066f952324 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_m4.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_8_m4 (gfc_array_i8 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_8_m4); + +void +maxloc1_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_4 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_4 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_UINTEGER_4 maxval; +#if defined (GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_4_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_m4 (gfc_array_i8 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_8_m4); + +void +mmaxloc1_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + const GFC_UINTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_8_m4 (retarray, array, pdim, back); +#else + maxloc1_8_m4 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_4 maxval; +#if defined (GFC_UINTEGER_4_INFINITY) + maxval = -GFC_UINTEGER_4_INFINITY; +#else + maxval = -GFC_UINTEGER_4_HUGE; +#endif +#if defined (GFC_UINTEGER_4_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_8_m4 (gfc_array_i8 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_8_m4); + +void +smaxloc1_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_8_m4 (retarray, array, pdim, back); +#else + maxloc1_8_m4 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/maxloc1_8_m8.c b/libgfortran/generated/maxloc1_8_m8.c new file mode 100644 index 00000000000..6c0588dfed8 --- /dev/null +++ b/libgfortran/generated/maxloc1_8_m8.c @@ -0,0 +1,591 @@ +/* Implementation of the MAXLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_8) + +#define HAVE_BACK_ARG 1 + + +extern void maxloc1_8_m8 (gfc_array_i8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(maxloc1_8_m8); + +void +maxloc1_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_8 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_UINTEGER_8 maxval; +#if defined (GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_8_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src >= maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } +#else + n = 0; +#endif + for (; n < len; n++, src += delta) + { + if (back ? *src >= maxval : *src > maxval) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mmaxloc1_8_m8 (gfc_array_i8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mmaxloc1_8_m8); + +void +mmaxloc1_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + const GFC_UINTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + maxloc1_8_m8 (retarray, array, pdim, back); +#else + maxloc1_8_m8 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MAXLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MAXLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MAXLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_8 maxval; +#if defined (GFC_UINTEGER_8_INFINITY) + maxval = -GFC_UINTEGER_8_INFINITY; +#else + maxval = -GFC_UINTEGER_8_HUGE; +#endif +#if defined (GFC_UINTEGER_8_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src >= maxval) +#endif + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src >= maxval)) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src > maxval)) + { + maxval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void smaxloc1_8_m8 (gfc_array_i8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(smaxloc1_8_m8); + +void +smaxloc1_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + maxloc1_8_m8 (retarray, array, pdim, back); +#else + maxloc1_8_m8 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MAXLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MAXLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MAXLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc0_16_m1.c b/libgfortran/generated/minloc0_16_m1.c new file mode 100644 index 00000000000..59038257ff3 --- /dev/null +++ b/libgfortran/generated/minloc0_16_m1.c @@ -0,0 +1,407 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_16_m1); + +void +minloc0_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_1 *base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_1 minval; +#if defined(GFC_UINTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_16_m1 (gfc_array_i16 * const restrict, + gfc_array_m1 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_16_m1); + +void +mminloc0_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + const GFC_UINTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_16_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_1 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_16_m1 (gfc_array_i16 * const restrict, + gfc_array_m1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_16_m1); + +void +sminloc0_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (mask == NULL || *mask) + { + minloc0_16_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_16_m16); + +void +minloc0_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_16 *base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_16 minval; +#if defined(GFC_UINTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_16_m16 (gfc_array_i16 * const restrict, + gfc_array_m16 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_16_m16); + +void +mminloc0_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + const GFC_UINTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_16_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_16 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_16_m16 (gfc_array_i16 * const restrict, + gfc_array_m16 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_16_m16); + +void +sminloc0_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (mask == NULL || *mask) + { + minloc0_16_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_16_m2); + +void +minloc0_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_2 *base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_2 minval; +#if defined(GFC_UINTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_16_m2 (gfc_array_i16 * const restrict, + gfc_array_m2 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_16_m2); + +void +mminloc0_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + const GFC_UINTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_16_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_2 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_16_m2 (gfc_array_i16 * const restrict, + gfc_array_m2 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_16_m2); + +void +sminloc0_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (mask == NULL || *mask) + { + minloc0_16_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_16_m4); + +void +minloc0_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_4 *base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_4 minval; +#if defined(GFC_UINTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_16_m4 (gfc_array_i16 * const restrict, + gfc_array_m4 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_16_m4); + +void +mminloc0_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + const GFC_UINTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_16_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_4 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_16_m4 (gfc_array_i16 * const restrict, + gfc_array_m4 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_16_m4); + +void +sminloc0_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (mask == NULL || *mask) + { + minloc0_16_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_16) + + +extern void minloc0_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_16_m8); + +void +minloc0_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_8 *base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_8 minval; +#if defined(GFC_UINTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_16_m8 (gfc_array_i16 * const restrict, + gfc_array_m8 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_16_m8); + +void +mminloc0_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_16 *dest; + const GFC_UINTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_16_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_8 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_16_m8 (gfc_array_i16 * const restrict, + gfc_array_m8 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_16_m8); + +void +sminloc0_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_16 *dest; + + if (mask == NULL || *mask) + { + minloc0_16_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_4_m1); + +void +minloc0_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_1 *base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_1 minval; +#if defined(GFC_UINTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_4_m1 (gfc_array_i4 * const restrict, + gfc_array_m1 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_4_m1); + +void +mminloc0_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + const GFC_UINTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_4_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_1 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_4_m1 (gfc_array_i4 * const restrict, + gfc_array_m1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_4_m1); + +void +sminloc0_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (mask == NULL || *mask) + { + minloc0_4_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_4_m16); + +void +minloc0_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_16 *base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_16 minval; +#if defined(GFC_UINTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_4_m16 (gfc_array_i4 * const restrict, + gfc_array_m16 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_4_m16); + +void +mminloc0_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + const GFC_UINTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_4_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_16 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_4_m16 (gfc_array_i4 * const restrict, + gfc_array_m16 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_4_m16); + +void +sminloc0_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (mask == NULL || *mask) + { + minloc0_4_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_4_m2); + +void +minloc0_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_2 *base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_2 minval; +#if defined(GFC_UINTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_4_m2 (gfc_array_i4 * const restrict, + gfc_array_m2 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_4_m2); + +void +mminloc0_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + const GFC_UINTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_4_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_2 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_4_m2 (gfc_array_i4 * const restrict, + gfc_array_m2 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_4_m2); + +void +sminloc0_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (mask == NULL || *mask) + { + minloc0_4_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_4_m4); + +void +minloc0_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_4 *base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_4 minval; +#if defined(GFC_UINTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_4_m4 (gfc_array_i4 * const restrict, + gfc_array_m4 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_4_m4); + +void +mminloc0_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + const GFC_UINTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_4_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_4 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_4_m4 (gfc_array_i4 * const restrict, + gfc_array_m4 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_4_m4); + +void +sminloc0_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (mask == NULL || *mask) + { + minloc0_4_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_4) + + +extern void minloc0_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_4_m8); + +void +minloc0_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_8 *base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_8 minval; +#if defined(GFC_UINTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_4_m8 (gfc_array_i4 * const restrict, + gfc_array_m8 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_4_m8); + +void +mminloc0_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_4 *dest; + const GFC_UINTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_4_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_8 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_4_m8 (gfc_array_i4 * const restrict, + gfc_array_m8 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_4_m8); + +void +sminloc0_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_4 *dest; + + if (mask == NULL || *mask) + { + minloc0_4_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_8_m1); + +void +minloc0_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_1 *base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_1 minval; +#if defined(GFC_UINTEGER_1_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_8_m1 (gfc_array_i8 * const restrict, + gfc_array_m1 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_8_m1); + +void +mminloc0_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + const GFC_UINTEGER_1 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_8_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_1 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_8_m1 (gfc_array_i8 * const restrict, + gfc_array_m1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_8_m1); + +void +sminloc0_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (mask == NULL || *mask) + { + minloc0_8_m1 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_8_m16); + +void +minloc0_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_16 *base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_16 minval; +#if defined(GFC_UINTEGER_16_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_8_m16 (gfc_array_i8 * const restrict, + gfc_array_m16 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_8_m16); + +void +mminloc0_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + const GFC_UINTEGER_16 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_8_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_16 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_8_m16 (gfc_array_i8 * const restrict, + gfc_array_m16 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_8_m16); + +void +sminloc0_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (mask == NULL || *mask) + { + minloc0_8_m16 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_8_m2); + +void +minloc0_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_2 *base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_2 minval; +#if defined(GFC_UINTEGER_2_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_8_m2 (gfc_array_i8 * const restrict, + gfc_array_m2 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_8_m2); + +void +mminloc0_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + const GFC_UINTEGER_2 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_8_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_2 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_8_m2 (gfc_array_i8 * const restrict, + gfc_array_m2 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_8_m2); + +void +sminloc0_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (mask == NULL || *mask) + { + minloc0_8_m2 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_8_m4); + +void +minloc0_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_4 *base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_4 minval; +#if defined(GFC_UINTEGER_4_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_8_m4 (gfc_array_i8 * const restrict, + gfc_array_m4 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_8_m4); + +void +mminloc0_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + const GFC_UINTEGER_4 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_8_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_4 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_8_m4 (gfc_array_i8 * const restrict, + gfc_array_m4 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_8_m4); + +void +sminloc0_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (mask == NULL || *mask) + { + minloc0_8_m4 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran 95 runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_8) + + +extern void minloc0_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4); +export_proto(minloc0_8_m8); + +void +minloc0_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + const GFC_UINTEGER_8 *base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 1; + { + + GFC_UINTEGER_8 minval; +#if defined(GFC_UINTEGER_8_QUIET_NAN) + int fast = 0; +#endif + +#if defined(GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (!fast)) + { + do + { + if (*base <= minval) + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else +#endif + if (back) + do + { + if (unlikely (*base <= minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*base < minval)) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void mminloc0_8_m8 (gfc_array_i8 * const restrict, + gfc_array_m8 * const restrict, gfc_array_l1 * const restrict, + GFC_LOGICAL_4); +export_proto(mminloc0_8_m8); + +void +mminloc0_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + index_type dstride; + GFC_INTEGER_8 *dest; + const GFC_UINTEGER_8 *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + + if (mask == NULL) + { + minloc0_8_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else + { + if (unlikely (compile_options.bounds_check)) + { + + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + { + /* Set the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + return; + } + } + + base = array->base_addr; + + /* Initialize the return value. */ + for (n = 0; n < rank; n++) + dest[n * dstride] = 0; + { + + GFC_UINTEGER_8 minval; + int fast = 0; + +#if defined(GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif + while (base) + { + /* Implementation start. */ + + if (unlikely (!fast)) + { + do + { + if (*mbase) + { +#if defined(GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (dest[0] == 0)) + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + if (*base <= minval) +#endif + { + fast = 1; + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + break; + } + } + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + if (likely (fast)) + continue; + } + else + if (back) + do + { + if (unlikely (*mbase && (*base <= minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + base += sstride[0]; + } + while (++count[0] != extent[0]); + else + do + { + if (unlikely (*mbase && (*base < minval))) + { + minval = *base; + for (n = 0; n < rank; n++) + dest[n * dstride] = count[n] + 1; + } + /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + } +} + +extern void sminloc0_8_m8 (gfc_array_i8 * const restrict, + gfc_array_m8 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4); +export_proto(sminloc0_8_m8); + +void +sminloc0_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type rank; + index_type dstride; + index_type n; + GFC_INTEGER_8 *dest; + + if (mask == NULL || *mask) + { + minloc0_8_m8 (retarray, array, back); + return; + } + + rank = GFC_DESCRIPTOR_RANK (array); + + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + if (retarray->base_addr == NULL) + { + GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); + retarray->dtype.rank = 1; + retarray->offset = 0; + retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8)); + } + else if (unlikely (compile_options.bounds_check)) + { + bounds_iforeach_return ((array_t *) retarray, (array_t *) array, + "MINLOC"); + } + + dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); + dest = retarray->base_addr; + for (n = 0; n + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_16) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_16_m1 (gfc_array_i16 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_16_m1); + +void +minloc1_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_1 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_1 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_UINTEGER_1 minval; +#if defined (GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_1_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_16) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_m1 (gfc_array_i16 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_16_m1); + +void +mminloc1_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + const GFC_UINTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_16_m1 (retarray, array, pdim, back); +#else + minloc1_16_m1 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_1 minval; +#if defined (GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif +#if defined (GFC_UINTEGER_1_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_16) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_16_m1 (gfc_array_i16 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_16_m1); + +void +sminloc1_16_m1 (gfc_array_i16 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_16_m1 (retarray, array, pdim, back); +#else + minloc1_16_m1 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_m16.c b/libgfortran/generated/minloc1_16_m16.c new file mode 100644 index 00000000000..d675e3a1070 --- /dev/null +++ b/libgfortran/generated/minloc1_16_m16.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_16) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_16_m16 (gfc_array_i16 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_16_m16); + +void +minloc1_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_16 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_16 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_UINTEGER_16 minval; +#if defined (GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_16_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_16) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_m16 (gfc_array_i16 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_16_m16); + +void +mminloc1_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + const GFC_UINTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_16_m16 (retarray, array, pdim, back); +#else + minloc1_16_m16 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_16 minval; +#if defined (GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif +#if defined (GFC_UINTEGER_16_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_16) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_16_m16 (gfc_array_i16 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_16_m16); + +void +sminloc1_16_m16 (gfc_array_i16 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_16_m16 (retarray, array, pdim, back); +#else + minloc1_16_m16 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_m2.c b/libgfortran/generated/minloc1_16_m2.c new file mode 100644 index 00000000000..6652d225112 --- /dev/null +++ b/libgfortran/generated/minloc1_16_m2.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_16) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_16_m2 (gfc_array_i16 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_16_m2); + +void +minloc1_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_2 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_2 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_UINTEGER_2 minval; +#if defined (GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_2_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_16) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_m2 (gfc_array_i16 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_16_m2); + +void +mminloc1_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + const GFC_UINTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_16_m2 (retarray, array, pdim, back); +#else + minloc1_16_m2 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_2 minval; +#if defined (GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif +#if defined (GFC_UINTEGER_2_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_16) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_16_m2 (gfc_array_i16 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_16_m2); + +void +sminloc1_16_m2 (gfc_array_i16 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_16_m2 (retarray, array, pdim, back); +#else + minloc1_16_m2 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_m4.c b/libgfortran/generated/minloc1_16_m4.c new file mode 100644 index 00000000000..94f6fca06a4 --- /dev/null +++ b/libgfortran/generated/minloc1_16_m4.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_16) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_16_m4 (gfc_array_i16 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_16_m4); + +void +minloc1_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_4 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_4 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_UINTEGER_4 minval; +#if defined (GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_4_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_16) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_m4 (gfc_array_i16 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_16_m4); + +void +mminloc1_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + const GFC_UINTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_16_m4 (retarray, array, pdim, back); +#else + minloc1_16_m4 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_4 minval; +#if defined (GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif +#if defined (GFC_UINTEGER_4_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_16) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_16_m4 (gfc_array_i16 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_16_m4); + +void +sminloc1_16_m4 (gfc_array_i16 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_16_m4 (retarray, array, pdim, back); +#else + minloc1_16_m4 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_16_m8.c b/libgfortran/generated/minloc1_16_m8.c new file mode 100644 index 00000000000..fc9297fd046 --- /dev/null +++ b/libgfortran/generated/minloc1_16_m8.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_16) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_16_m8 (gfc_array_i16 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_16_m8); + +void +minloc1_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_8 * restrict base; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_8 * restrict src; + GFC_INTEGER_16 result; + src = base; + { + + GFC_UINTEGER_8 minval; +#if defined (GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_8_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_16) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_16_m8 (gfc_array_i16 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_16_m8); + +void +mminloc1_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + const GFC_UINTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_16_m8 (retarray, array, pdim, back); +#else + minloc1_16_m8 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_16 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_8 minval; +#if defined (GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif +#if defined (GFC_UINTEGER_8_QUIET_NAN) + GFC_INTEGER_16 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_16)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_16)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_16) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_16_m8 (gfc_array_i16 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_16_m8); + +void +sminloc1_16_m8 (gfc_array_i16 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_16 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_16_m8 (retarray, array, pdim, back); +#else + minloc1_16_m8 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_m1.c b/libgfortran/generated/minloc1_4_m1.c new file mode 100644 index 00000000000..fc2d9cfcb03 --- /dev/null +++ b/libgfortran/generated/minloc1_4_m1.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_4) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_4_m1 (gfc_array_i4 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_4_m1); + +void +minloc1_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_1 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_1 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_UINTEGER_1 minval; +#if defined (GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_1_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_4) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_m1 (gfc_array_i4 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_4_m1); + +void +mminloc1_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_UINTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_4_m1 (retarray, array, pdim, back); +#else + minloc1_4_m1 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_1 minval; +#if defined (GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif +#if defined (GFC_UINTEGER_1_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_4) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_4_m1 (gfc_array_i4 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_4_m1); + +void +sminloc1_4_m1 (gfc_array_i4 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_4_m1 (retarray, array, pdim, back); +#else + minloc1_4_m1 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_m16.c b/libgfortran/generated/minloc1_4_m16.c new file mode 100644 index 00000000000..ab6b1d6d318 --- /dev/null +++ b/libgfortran/generated/minloc1_4_m16.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_4) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_4_m16 (gfc_array_i4 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_4_m16); + +void +minloc1_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_16 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_16 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_UINTEGER_16 minval; +#if defined (GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_16_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_4) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_m16 (gfc_array_i4 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_4_m16); + +void +mminloc1_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_UINTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_4_m16 (retarray, array, pdim, back); +#else + minloc1_4_m16 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_16 minval; +#if defined (GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif +#if defined (GFC_UINTEGER_16_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_4) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_4_m16 (gfc_array_i4 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_4_m16); + +void +sminloc1_4_m16 (gfc_array_i4 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_4_m16 (retarray, array, pdim, back); +#else + minloc1_4_m16 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_m2.c b/libgfortran/generated/minloc1_4_m2.c new file mode 100644 index 00000000000..5de3231824b --- /dev/null +++ b/libgfortran/generated/minloc1_4_m2.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_4) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_4_m2 (gfc_array_i4 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_4_m2); + +void +minloc1_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_2 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_2 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_UINTEGER_2 minval; +#if defined (GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_2_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_4) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_m2 (gfc_array_i4 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_4_m2); + +void +mminloc1_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_UINTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_4_m2 (retarray, array, pdim, back); +#else + minloc1_4_m2 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_2 minval; +#if defined (GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif +#if defined (GFC_UINTEGER_2_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_4) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_4_m2 (gfc_array_i4 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_4_m2); + +void +sminloc1_4_m2 (gfc_array_i4 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_4_m2 (retarray, array, pdim, back); +#else + minloc1_4_m2 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_m4.c b/libgfortran/generated/minloc1_4_m4.c new file mode 100644 index 00000000000..090608d478f --- /dev/null +++ b/libgfortran/generated/minloc1_4_m4.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_4_m4 (gfc_array_i4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_4_m4); + +void +minloc1_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_4 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_4 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_UINTEGER_4 minval; +#if defined (GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_4_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_4) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_m4 (gfc_array_i4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_4_m4); + +void +mminloc1_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_UINTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_4_m4 (retarray, array, pdim, back); +#else + minloc1_4_m4 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_4 minval; +#if defined (GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif +#if defined (GFC_UINTEGER_4_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_4) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_4_m4 (gfc_array_i4 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_4_m4); + +void +sminloc1_4_m4 (gfc_array_i4 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_4_m4 (retarray, array, pdim, back); +#else + minloc1_4_m4 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_4_m8.c b/libgfortran/generated/minloc1_4_m8.c new file mode 100644 index 00000000000..5c04e367349 --- /dev/null +++ b/libgfortran/generated/minloc1_4_m8.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_4) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_4_m8 (gfc_array_i4 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_4_m8); + +void +minloc1_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_8 * restrict base; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_8 * restrict src; + GFC_INTEGER_4 result; + src = base; + { + + GFC_UINTEGER_8 minval; +#if defined (GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_8_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_4) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_4_m8 (gfc_array_i4 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_4_m8); + +void +mminloc1_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + const GFC_UINTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_4_m8 (retarray, array, pdim, back); +#else + minloc1_4_m8 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_4 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_8 minval; +#if defined (GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif +#if defined (GFC_UINTEGER_8_QUIET_NAN) + GFC_INTEGER_4 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_4)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_4)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_4) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_4_m8 (gfc_array_i4 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_4_m8); + +void +sminloc1_4_m8 (gfc_array_i4 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_4 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_4_m8 (retarray, array, pdim, back); +#else + minloc1_4_m8 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_m1.c b/libgfortran/generated/minloc1_8_m1.c new file mode 100644 index 00000000000..c3b09ed60f6 --- /dev/null +++ b/libgfortran/generated/minloc1_8_m1.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_8_m1 (gfc_array_i8 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_8_m1); + +void +minloc1_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_1 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_1 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_UINTEGER_1 minval; +#if defined (GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_1_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_8) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_m1 (gfc_array_i8 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_8_m1); + +void +mminloc1_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + const GFC_UINTEGER_1 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_8_m1 (retarray, array, pdim, back); +#else + minloc1_8_m1 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_1 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_1 minval; +#if defined (GFC_UINTEGER_1_INFINITY) + minval = GFC_UINTEGER_1_INFINITY; +#else + minval = GFC_UINTEGER_1_HUGE; +#endif +#if defined (GFC_UINTEGER_1_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_1_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_8) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_8_m1 (gfc_array_i8 * const restrict, + gfc_array_m1 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_8_m1); + +void +sminloc1_8_m1 (gfc_array_i8 * const restrict retarray, + gfc_array_m1 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_8_m1 (retarray, array, pdim, back); +#else + minloc1_8_m1 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_m16.c b/libgfortran/generated/minloc1_8_m16.c new file mode 100644 index 00000000000..a105467c58c --- /dev/null +++ b/libgfortran/generated/minloc1_8_m16.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_16) && defined (HAVE_GFC_INTEGER_8) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_8_m16 (gfc_array_i8 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_8_m16); + +void +minloc1_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_16 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_16 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_UINTEGER_16 minval; +#if defined (GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_16_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_8) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_m16 (gfc_array_i8 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_8_m16); + +void +mminloc1_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + const GFC_UINTEGER_16 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_8_m16 (retarray, array, pdim, back); +#else + minloc1_8_m16 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_16 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_16 minval; +#if defined (GFC_UINTEGER_16_INFINITY) + minval = GFC_UINTEGER_16_INFINITY; +#else + minval = GFC_UINTEGER_16_HUGE; +#endif +#if defined (GFC_UINTEGER_16_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_16_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_8) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_8_m16 (gfc_array_i8 * const restrict, + gfc_array_m16 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_8_m16); + +void +sminloc1_8_m16 (gfc_array_i8 * const restrict retarray, + gfc_array_m16 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_8_m16 (retarray, array, pdim, back); +#else + minloc1_8_m16 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_m2.c b/libgfortran/generated/minloc1_8_m2.c new file mode 100644 index 00000000000..9a8f8de1315 --- /dev/null +++ b/libgfortran/generated/minloc1_8_m2.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_2) && defined (HAVE_GFC_INTEGER_8) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_8_m2 (gfc_array_i8 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_8_m2); + +void +minloc1_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_2 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_2 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_UINTEGER_2 minval; +#if defined (GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_2_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_8) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_m2 (gfc_array_i8 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_8_m2); + +void +mminloc1_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + const GFC_UINTEGER_2 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_8_m2 (retarray, array, pdim, back); +#else + minloc1_8_m2 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_2 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_2 minval; +#if defined (GFC_UINTEGER_2_INFINITY) + minval = GFC_UINTEGER_2_INFINITY; +#else + minval = GFC_UINTEGER_2_HUGE; +#endif +#if defined (GFC_UINTEGER_2_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_2_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_8) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_8_m2 (gfc_array_i8 * const restrict, + gfc_array_m2 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_8_m2); + +void +sminloc1_8_m2 (gfc_array_i8 * const restrict retarray, + gfc_array_m2 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_8_m2 (retarray, array, pdim, back); +#else + minloc1_8_m2 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_m4.c b/libgfortran/generated/minloc1_8_m4.c new file mode 100644 index 00000000000..6ba0e481f5b --- /dev/null +++ b/libgfortran/generated/minloc1_8_m4.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_8) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_8_m4 (gfc_array_i8 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_8_m4); + +void +minloc1_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_4 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_4 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_UINTEGER_4 minval; +#if defined (GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_4_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_8) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_m4 (gfc_array_i8 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_8_m4); + +void +mminloc1_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + const GFC_UINTEGER_4 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_8_m4 (retarray, array, pdim, back); +#else + minloc1_8_m4 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_4 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_4 minval; +#if defined (GFC_UINTEGER_4_INFINITY) + minval = GFC_UINTEGER_4_INFINITY; +#else + minval = GFC_UINTEGER_4_HUGE; +#endif +#if defined (GFC_UINTEGER_4_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_4_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_8) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_8_m4 (gfc_array_i8 * const restrict, + gfc_array_m4 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_8_m4); + +void +sminloc1_8_m4 (gfc_array_i8 * const restrict retarray, + gfc_array_m4 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_8_m4 (retarray, array, pdim, back); +#else + minloc1_8_m4 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/generated/minloc1_8_m8.c b/libgfortran/generated/minloc1_8_m8.c new file mode 100644 index 00000000000..f59e6ef1d57 --- /dev/null +++ b/libgfortran/generated/minloc1_8_m8.c @@ -0,0 +1,601 @@ +/* Implementation of the MINLOC intrinsic + Copyright (C) 2002-2024 Free Software Foundation, Inc. + Contributed by Paul Brook + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + + +#if defined (HAVE_GFC_UINTEGER_8) && defined (HAVE_GFC_INTEGER_8) + +#define HAVE_BACK_ARG 1 + + +extern void minloc1_8_m8 (gfc_array_i8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back); +export_proto(minloc1_8_m8); + +void +minloc1_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const GFC_UINTEGER_8 * restrict base; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const GFC_UINTEGER_8 * restrict src; + GFC_INTEGER_8 result; + src = base; + { + + GFC_UINTEGER_8 minval; +#if defined (GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif + result = 1; + if (len <= 0) + *dest = 0; + else + { +#if ! defined HAVE_BACK_ARG + for (n = 0; n < len; n++, src += delta) + { +#endif + +#if defined (GFC_UINTEGER_8_QUIET_NAN) + for (n = 0; n < len; n++, src += delta) + { + if (*src <= minval) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } +#else + n = 0; +#endif + if (back) + for (; n < len; n++, src += delta) + { + if (unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta) + { + if (unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_8) n + 1; + } + } + + *dest = result; + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void mminloc1_8_m8 (gfc_array_i8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + gfc_array_l1 * const restrict, GFC_LOGICAL_4 back); +export_proto(mminloc1_8_m8); + +void +mminloc1_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + const GFC_UINTEGER_8 * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + if (mask == NULL) + { +#ifdef HAVE_BACK_ARG + minloc1_8_m8 (retarray, array, pdim, back); +#else + minloc1_8_m8 (retarray, array, pdim); +#endif + return; + } + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim); + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->offset = 0; + retarray->dtype.rank = rank; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in MINLOC intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "MINLOC"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "MINLOC"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const GFC_UINTEGER_8 * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + GFC_INTEGER_8 result; + src = base; + msrc = mbase; + { + + GFC_UINTEGER_8 minval; +#if defined (GFC_UINTEGER_8_INFINITY) + minval = GFC_UINTEGER_8_INFINITY; +#else + minval = GFC_UINTEGER_8_HUGE; +#endif +#if defined (GFC_UINTEGER_8_QUIET_NAN) + GFC_INTEGER_8 result2 = 0; +#endif + result = 0; + for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { + + if (*msrc) + { +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (!result2) + result2 = (GFC_INTEGER_8)n + 1; + if (*src <= minval) +#endif + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + break; + } + } + } +#if defined (GFC_UINTEGER_8_QUIET_NAN) + if (unlikely (n >= len)) + result = result2; + else +#endif + if (back) + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src <= minval)) + { + minval = *src; + result = (GFC_INTEGER_8)n + 1; + } + } + else + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && unlikely (*src < minval)) + { + minval = *src; + result = (GFC_INTEGER_8) n + 1; + } + } + *dest = result; + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +} + + +extern void sminloc1_8_m8 (gfc_array_i8 * const restrict, + gfc_array_m8 * const restrict, const index_type * const restrict, + GFC_LOGICAL_4 *, GFC_LOGICAL_4 back); +export_proto(sminloc1_8_m8); + +void +sminloc1_8_m8 (gfc_array_i8 * const restrict retarray, + gfc_array_m8 * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + GFC_INTEGER_8 * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (mask == NULL || *mask) + { +#ifdef HAVE_BACK_ARG + minloc1_8_m8 (retarray, array, pdim, back); +#else + minloc1_8_m8 (retarray, array, pdim); +#endif + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in MINLOC intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype.rank = rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8)); + if (alloc_size == 0) + return; + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " MINLOC intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " MINLOC intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); + } + + dest = retarray->base_addr; + + while(1) + { + *dest = 0; + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +} + +#endif diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index ebde691ae4f..f58edc52e3c 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1817,4 +1817,184 @@ GFORTRAN_15 { _gfortran_smaxval_m2; _gfortran_smaxval_m4; _gfortran_smaxval_m8; + _gfortran_maxloc0_16_m16; + _gfortran_maxloc0_16_m1; + _gfortran_maxloc0_16_m2; + _gfortran_maxloc0_16_m4; + _gfortran_maxloc0_16_m8; + _gfortran_maxloc0_4_m16; + _gfortran_maxloc0_4_m1; + _gfortran_maxloc0_4_m2; + _gfortran_maxloc0_4_m4; + _gfortran_maxloc0_4_m8; + _gfortran_maxloc0_8_m16; + _gfortran_maxloc0_8_m1; + _gfortran_maxloc0_8_m2; + _gfortran_maxloc0_8_m4; + _gfortran_maxloc0_8_m8; + _gfortran_maxloc1_16_m16; + _gfortran_maxloc1_16_m1; + _gfortran_maxloc1_16_m2; + _gfortran_maxloc1_16_m4; + _gfortran_maxloc1_16_m8; + _gfortran_maxloc1_4_m16; + _gfortran_maxloc1_4_m1; + _gfortran_maxloc1_4_m2; + _gfortran_maxloc1_4_m4; + _gfortran_maxloc1_4_m8; + _gfortran_maxloc1_8_m16; + _gfortran_maxloc1_8_m1; + _gfortran_maxloc1_8_m2; + _gfortran_maxloc1_8_m4; + _gfortran_maxloc1_8_m8; + _gfortran_mmaxloc0_16_m16; + _gfortran_mmaxloc0_16_m1; + _gfortran_mmaxloc0_16_m2; + _gfortran_mmaxloc0_16_m4; + _gfortran_mmaxloc0_16_m8; + _gfortran_mmaxloc0_4_m16; + _gfortran_mmaxloc0_4_m1; + _gfortran_mmaxloc0_4_m2; + _gfortran_mmaxloc0_4_m4; + _gfortran_mmaxloc0_4_m8; + _gfortran_mmaxloc0_8_m16; + _gfortran_mmaxloc0_8_m1; + _gfortran_mmaxloc0_8_m2; + _gfortran_mmaxloc0_8_m4; + _gfortran_mmaxloc0_8_m8; + _gfortran_mmaxloc1_16_m16; + _gfortran_mmaxloc1_16_m1; + _gfortran_mmaxloc1_16_m2; + _gfortran_mmaxloc1_16_m4; + _gfortran_mmaxloc1_16_m8; + _gfortran_mmaxloc1_4_m16; + _gfortran_mmaxloc1_4_m1; + _gfortran_mmaxloc1_4_m2; + _gfortran_mmaxloc1_4_m4; + _gfortran_mmaxloc1_4_m8; + _gfortran_mmaxloc1_8_m16; + _gfortran_mmaxloc1_8_m1; + _gfortran_mmaxloc1_8_m2; + _gfortran_mmaxloc1_8_m4; + _gfortran_mmaxloc1_8_m8; + _gfortran_smaxloc0_16_m16; + _gfortran_smaxloc0_16_m1; + _gfortran_smaxloc0_16_m2; + _gfortran_smaxloc0_16_m4; + _gfortran_smaxloc0_16_m8; + _gfortran_smaxloc0_4_m16; + _gfortran_smaxloc0_4_m1; + _gfortran_smaxloc0_4_m2; + _gfortran_smaxloc0_4_m4; + _gfortran_smaxloc0_4_m8; + _gfortran_smaxloc0_8_m16; + _gfortran_smaxloc0_8_m1; + _gfortran_smaxloc0_8_m2; + _gfortran_smaxloc0_8_m4; + _gfortran_smaxloc0_8_m8; + _gfortran_smaxloc1_16_m16; + _gfortran_smaxloc1_16_m1; + _gfortran_smaxloc1_16_m2; + _gfortran_smaxloc1_16_m4; + _gfortran_smaxloc1_16_m8; + _gfortran_smaxloc1_4_m16; + _gfortran_smaxloc1_4_m1; + _gfortran_smaxloc1_4_m2; + _gfortran_smaxloc1_4_m4; + _gfortran_smaxloc1_4_m8; + _gfortran_smaxloc1_8_m16; + _gfortran_smaxloc1_8_m1; + _gfortran_smaxloc1_8_m2; + _gfortran_smaxloc1_8_m4; + _gfortran_smaxloc1_8_m8; + _gfortran_minloc0_16_m16; + _gfortran_minloc0_16_m1; + _gfortran_minloc0_16_m2; + _gfortran_minloc0_16_m4; + _gfortran_minloc0_16_m8; + _gfortran_minloc0_4_m16; + _gfortran_minloc0_4_m1; + _gfortran_minloc0_4_m2; + _gfortran_minloc0_4_m4; + _gfortran_minloc0_4_m8; + _gfortran_minloc0_8_m16; + _gfortran_minloc0_8_m1; + _gfortran_minloc0_8_m2; + _gfortran_minloc0_8_m4; + _gfortran_minloc0_8_m8; + _gfortran_minloc1_16_m16; + _gfortran_minloc1_16_m1; + _gfortran_minloc1_16_m2; + _gfortran_minloc1_16_m4; + _gfortran_minloc1_16_m8; + _gfortran_minloc1_4_m16; + _gfortran_minloc1_4_m1; + _gfortran_minloc1_4_m2; + _gfortran_minloc1_4_m4; + _gfortran_minloc1_4_m8; + _gfortran_minloc1_8_m16; + _gfortran_minloc1_8_m1; + _gfortran_minloc1_8_m2; + _gfortran_minloc1_8_m4; + _gfortran_minloc1_8_m8; + _gfortran_mminloc0_16_m16; + _gfortran_mminloc0_16_m1; + _gfortran_mminloc0_16_m2; + _gfortran_mminloc0_16_m4; + _gfortran_mminloc0_16_m8; + _gfortran_mminloc0_4_m16; + _gfortran_mminloc0_4_m1; + _gfortran_mminloc0_4_m2; + _gfortran_mminloc0_4_m4; + _gfortran_mminloc0_4_m8; + _gfortran_mminloc0_8_m16; + _gfortran_mminloc0_8_m1; + _gfortran_mminloc0_8_m2; + _gfortran_mminloc0_8_m4; + _gfortran_mminloc0_8_m8; + _gfortran_mminloc1_16_m16; + _gfortran_mminloc1_16_m1; + _gfortran_mminloc1_16_m2; + _gfortran_mminloc1_16_m4; + _gfortran_mminloc1_16_m8; + _gfortran_mminloc1_4_m16; + _gfortran_mminloc1_4_m1; + _gfortran_mminloc1_4_m2; + _gfortran_mminloc1_4_m4; + _gfortran_mminloc1_4_m8; + _gfortran_mminloc1_8_m16; + _gfortran_mminloc1_8_m1; + _gfortran_mminloc1_8_m2; + _gfortran_mminloc1_8_m4; + _gfortran_mminloc1_8_m8; + _gfortran_sminloc0_16_m16; + _gfortran_sminloc0_16_m1; + _gfortran_sminloc0_16_m2; + _gfortran_sminloc0_16_m4; + _gfortran_sminloc0_16_m8; + _gfortran_sminloc0_4_m16; + _gfortran_sminloc0_4_m1; + _gfortran_sminloc0_4_m2; + _gfortran_sminloc0_4_m4; + _gfortran_sminloc0_4_m8; + _gfortran_sminloc0_8_m16; + _gfortran_sminloc0_8_m1; + _gfortran_sminloc0_8_m2; + _gfortran_sminloc0_8_m4; + _gfortran_sminloc0_8_m8; + _gfortran_sminloc1_16_m16; + _gfortran_sminloc1_16_m1; + _gfortran_sminloc1_16_m2; + _gfortran_sminloc1_16_m4; + _gfortran_sminloc1_16_m8; + _gfortran_sminloc1_4_m16; + _gfortran_sminloc1_4_m1; + _gfortran_sminloc1_4_m2; + _gfortran_sminloc1_4_m4; + _gfortran_sminloc1_4_m8; + _gfortran_sminloc1_8_m16; + _gfortran_sminloc1_8_m1; + _gfortran_sminloc1_8_m2; + _gfortran_sminloc1_8_m4; + _gfortran_sminloc1_8_m8; } GFORTRAN_14;