summaryrefslogtreecommitdiff
path: root/libgfortran/generated
diff options
context:
space:
mode:
authorThomas Koenig <tkoenig@gcc.gnu.org>2017-11-22 18:08:07 +0000
committerThomas Koenig <tkoenig@gcc.gnu.org>2017-11-22 18:08:07 +0000
commitddc9995b13d71d00b97cb2c4c7d5e9ef1dcbe5ea (patch)
treea56711799c15dbdca3426f951fa31ef645b06e75 /libgfortran/generated
parent824a2b3d8cb18e80ed11231ed57b4bf67134fcd0 (diff)
downloadgcc-ddc9995b13d71d00b97cb2c4c7d5e9ef1dcbe5ea.tar.gz
re PR fortran/36313 ([F03] {MIN,MAX}{LOC,VAL} should accept character arguments)
2017-11-22 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/36313 * Makefile.am: Add i_maxloc0s_c, i_maxloc1s_c, i_maxloc2s_c, i_minloc0s_c, i_minloc1s_c and i_minloc2s_c. * Makefile.in: Regenerated. * generated/maxloc0_16_s1.c: New file. * generated/maxloc0_16_s4.c: New file. * generated/maxloc0_4_s1.c: New file. * generated/maxloc0_4_s4.c: New file. * generated/maxloc0_8_s1.c: New file. * generated/maxloc0_8_s4.c: New file. * generated/maxloc1_16_s1.c: New file. * generated/maxloc1_16_s4.c: New file. * generated/maxloc1_4_s1.c: New file. * generated/maxloc1_4_s4.c: New file. * generated/maxloc1_8_s1.c: New file. * generated/maxloc1_8_s4.c: New file. * generated/maxloc2_16_s1.c: New file. * generated/maxloc2_16_s4.c: New file. * generated/maxloc2_4_s1.c: New file. * generated/maxloc2_4_s4.c: New file. * generated/maxloc2_8_s1.c: New file. * generated/maxloc2_8_s4.c: New file. * generated/minloc0_16_s1.c: New file. * generated/minloc0_16_s4.c: New file. * generated/minloc0_4_s1.c: New file. * generated/minloc0_4_s4.c: New file. * generated/minloc0_8_s1.c: New file. * generated/minloc0_8_s4.c: New file. * generated/minloc1_16_s1.c: New file. * generated/minloc1_16_s4.c: New file. * generated/minloc1_4_s1.c: New file. * generated/minloc1_4_s4.c: New file. * generated/minloc1_8_s1.c: New file. * generated/minloc1_8_s4.c: New file. * generated/minloc2_16_s1.c: New file. * generated/minloc2_16_s4.c: New file. * generated/minloc2_4_s1.c: New file. * generated/minloc2_4_s4.c: New file. * generated/minloc2_8_s1.c: New file. * generated/minloc2_8_s4.c: New file. * m4/iforeach-s.m4: New file. * m4/ifunction-s.m4: New file. * m4/maxloc0s.m4: New file. * m4/maxloc1s.m4: New file. * m4/maxloc2s.m4: New file. * m4/minloc0s.m4: New file. * m4/minloc1s.m4: New file. * m4/minloc2s.m4: New file. * gfortran.map: Add new functions. * libgfortran.h: Add gfc_array_s1 and gfc_array_s4. 2017-11-22 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/36313 * check.c (int_or_real_or_char_check_f2003): New function. * iresolve.c (gfc_resolve_maxloc): Add number "2" for character arguments and rank-zero return value. (gfc_resolve_minloc): Likewise. * trans-intrinsic.c (gfc_conv_intrinsic_minmaxloc): Handle case of character arguments and rank-zero return value by removing unneeded arguments and calling the library function. 2017-11-22 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/36313 * gfortran.dg/maxloc_string_1.f90: New test. * gfortran.dg/minloc_string_1.f90: New test. From-SVN: r255070
Diffstat (limited to 'libgfortran/generated')
-rw-r--r--libgfortran/generated/maxloc0_16_s1.c327
-rw-r--r--libgfortran/generated/maxloc0_16_s4.c327
-rw-r--r--libgfortran/generated/maxloc0_4_s1.c327
-rw-r--r--libgfortran/generated/maxloc0_4_s4.c327
-rw-r--r--libgfortran/generated/maxloc0_8_s1.c327
-rw-r--r--libgfortran/generated/maxloc0_8_s4.c327
-rw-r--r--libgfortran/generated/maxloc1_16_s1.c552
-rw-r--r--libgfortran/generated/maxloc1_16_s4.c552
-rw-r--r--libgfortran/generated/maxloc1_4_s1.c552
-rw-r--r--libgfortran/generated/maxloc1_4_s4.c552
-rw-r--r--libgfortran/generated/maxloc1_8_s1.c552
-rw-r--r--libgfortran/generated/maxloc1_8_s4.c552
-rw-r--r--libgfortran/generated/maxloc2_16_s1.c156
-rw-r--r--libgfortran/generated/maxloc2_16_s4.c156
-rw-r--r--libgfortran/generated/maxloc2_4_s1.c156
-rw-r--r--libgfortran/generated/maxloc2_4_s4.c156
-rw-r--r--libgfortran/generated/maxloc2_8_s1.c156
-rw-r--r--libgfortran/generated/maxloc2_8_s4.c156
-rw-r--r--libgfortran/generated/minloc0_16_s1.c327
-rw-r--r--libgfortran/generated/minloc0_16_s4.c327
-rw-r--r--libgfortran/generated/minloc0_4_s1.c327
-rw-r--r--libgfortran/generated/minloc0_4_s4.c327
-rw-r--r--libgfortran/generated/minloc0_8_s1.c327
-rw-r--r--libgfortran/generated/minloc0_8_s4.c327
-rw-r--r--libgfortran/generated/minloc1_16_s1.c552
-rw-r--r--libgfortran/generated/minloc1_16_s4.c552
-rw-r--r--libgfortran/generated/minloc1_4_s1.c552
-rw-r--r--libgfortran/generated/minloc1_4_s4.c552
-rw-r--r--libgfortran/generated/minloc1_8_s1.c552
-rw-r--r--libgfortran/generated/minloc1_8_s4.c552
-rw-r--r--libgfortran/generated/minloc2_16_s1.c155
-rw-r--r--libgfortran/generated/minloc2_16_s4.c155
-rw-r--r--libgfortran/generated/minloc2_4_s1.c155
-rw-r--r--libgfortran/generated/minloc2_4_s4.c155
-rw-r--r--libgfortran/generated/minloc2_8_s1.c155
-rw-r--r--libgfortran/generated/minloc2_8_s4.c155
36 files changed, 12414 insertions, 0 deletions
diff --git a/libgfortran/generated/maxloc0_16_s1.c b/libgfortran/generated/maxloc0_16_s1.c
new file mode 100644
index 00000000000..949fb209901
--- /dev/null
+++ b/libgfortran/generated/maxloc0_16_s1.c
@@ -0,0 +1,327 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void maxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len);
+export_proto(maxloc0_16_s1);
+
+void
+maxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+ maxval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, maxval, len) > 0)
+ {
+ 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_s1 (gfc_array_i16 * const restrict,
+ gfc_array_s1 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mmaxloc0_16_s1);
+
+void
+mmaxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_1 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+
+ maxval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (maxval == NULL || compare_fcn (base, maxval, len) > 0))
+ {
+ 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_s1 (gfc_array_i16 * const restrict,
+ gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(smaxloc0_16_s1);
+
+void
+smaxloc0_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_16 *dest;
+
+ if (*mask)
+ {
+ maxloc0_16_s1 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/maxloc0_16_s4.c b/libgfortran/generated/maxloc0_16_s4.c
new file mode 100644
index 00000000000..1ac7a9da1a6
--- /dev/null
+++ b/libgfortran/generated/maxloc0_16_s4.c
@@ -0,0 +1,327 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void maxloc0_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len);
+export_proto(maxloc0_16_s4);
+
+void
+maxloc0_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+ maxval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, maxval, len) > 0)
+ {
+ 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_s4 (gfc_array_i16 * const restrict,
+ gfc_array_s4 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mmaxloc0_16_s4);
+
+void
+mmaxloc0_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_4 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+
+ maxval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (maxval == NULL || compare_fcn (base, maxval, len) > 0))
+ {
+ 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_s4 (gfc_array_i16 * const restrict,
+ gfc_array_s4 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(smaxloc0_16_s4);
+
+void
+smaxloc0_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_16 *dest;
+
+ if (*mask)
+ {
+ maxloc0_16_s4 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/maxloc0_4_s1.c b/libgfortran/generated/maxloc0_4_s1.c
new file mode 100644
index 00000000000..6d897d8a835
--- /dev/null
+++ b/libgfortran/generated/maxloc0_4_s1.c
@@ -0,0 +1,327 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void maxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len);
+export_proto(maxloc0_4_s1);
+
+void
+maxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+ maxval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, maxval, len) > 0)
+ {
+ 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_s1 (gfc_array_i4 * const restrict,
+ gfc_array_s1 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mmaxloc0_4_s1);
+
+void
+mmaxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_1 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+
+ maxval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (maxval == NULL || compare_fcn (base, maxval, len) > 0))
+ {
+ 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_s1 (gfc_array_i4 * const restrict,
+ gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(smaxloc0_4_s1);
+
+void
+smaxloc0_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_4 *dest;
+
+ if (*mask)
+ {
+ maxloc0_4_s1 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/maxloc0_4_s4.c b/libgfortran/generated/maxloc0_4_s4.c
new file mode 100644
index 00000000000..3a8e603fe92
--- /dev/null
+++ b/libgfortran/generated/maxloc0_4_s4.c
@@ -0,0 +1,327 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void maxloc0_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len);
+export_proto(maxloc0_4_s4);
+
+void
+maxloc0_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+ maxval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, maxval, len) > 0)
+ {
+ 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_s4 (gfc_array_i4 * const restrict,
+ gfc_array_s4 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mmaxloc0_4_s4);
+
+void
+mmaxloc0_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_4 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+
+ maxval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (maxval == NULL || compare_fcn (base, maxval, len) > 0))
+ {
+ 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_s4 (gfc_array_i4 * const restrict,
+ gfc_array_s4 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(smaxloc0_4_s4);
+
+void
+smaxloc0_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_4 *dest;
+
+ if (*mask)
+ {
+ maxloc0_4_s4 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/maxloc0_8_s1.c b/libgfortran/generated/maxloc0_8_s1.c
new file mode 100644
index 00000000000..f01973604a7
--- /dev/null
+++ b/libgfortran/generated/maxloc0_8_s1.c
@@ -0,0 +1,327 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void maxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len);
+export_proto(maxloc0_8_s1);
+
+void
+maxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+ maxval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, maxval, len) > 0)
+ {
+ 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_s1 (gfc_array_i8 * const restrict,
+ gfc_array_s1 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mmaxloc0_8_s1);
+
+void
+mmaxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_1 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+
+ maxval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (maxval == NULL || compare_fcn (base, maxval, len) > 0))
+ {
+ 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_s1 (gfc_array_i8 * const restrict,
+ gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(smaxloc0_8_s1);
+
+void
+smaxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_8 *dest;
+
+ if (*mask)
+ {
+ maxloc0_8_s1 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/maxloc0_8_s4.c b/libgfortran/generated/maxloc0_8_s4.c
new file mode 100644
index 00000000000..524a6215222
--- /dev/null
+++ b/libgfortran/generated/maxloc0_8_s4.c
@@ -0,0 +1,327 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void maxloc0_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len);
+export_proto(maxloc0_8_s4);
+
+void
+maxloc0_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+ maxval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, maxval, len) > 0)
+ {
+ 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_s4 (gfc_array_i8 * const restrict,
+ gfc_array_s4 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mmaxloc0_8_s4);
+
+void
+mmaxloc0_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_4 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+
+ maxval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (maxval == NULL || compare_fcn (base, maxval, len) > 0))
+ {
+ 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_s4 (gfc_array_i8 * const restrict,
+ gfc_array_s4 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(smaxloc0_8_s4);
+
+void
+smaxloc0_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_8 *dest;
+
+ if (*mask)
+ {
+ maxloc0_8_s4 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/maxloc1_16_s1.c b/libgfortran/generated/maxloc1_16_s1.c
new file mode 100644
index 00000000000..b8efc0aadea
--- /dev/null
+++ b/libgfortran/generated/maxloc1_16_s1.c
@@ -0,0 +1,552 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void maxloc1_16_s1 (gfc_array_i16 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(maxloc1_16_s1);
+
+void
+maxloc1_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_1 * restrict src;
+ GFC_INTEGER_16 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+ maxval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s1 (gfc_array_i16 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mmaxloc1_16_s1);
+
+void
+mmaxloc1_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
+
+ }
+ 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_INTEGER_1 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_16 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+ maxval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ maxval = src;
+ result = (GFC_INTEGER_16)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s1 (gfc_array_i16 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(smaxloc1_16_s1);
+
+void
+smaxloc1_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ maxloc1_16_s1 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
+ }
+ 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_s4.c b/libgfortran/generated/maxloc1_16_s4.c
new file mode 100644
index 00000000000..466d3627059
--- /dev/null
+++ b/libgfortran/generated/maxloc1_16_s4.c
@@ -0,0 +1,552 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void maxloc1_16_s4 (gfc_array_i16 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(maxloc1_16_s4);
+
+void
+maxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_4 * restrict src;
+ GFC_INTEGER_16 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+ maxval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s4 (gfc_array_i16 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mmaxloc1_16_s4);
+
+void
+mmaxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
+
+ }
+ 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_INTEGER_4 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_16 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+ maxval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ maxval = src;
+ result = (GFC_INTEGER_16)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s4 (gfc_array_i16 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(smaxloc1_16_s4);
+
+void
+smaxloc1_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ maxloc1_16_s4 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
+ }
+ 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_s1.c b/libgfortran/generated/maxloc1_4_s1.c
new file mode 100644
index 00000000000..6116e5be1af
--- /dev/null
+++ b/libgfortran/generated/maxloc1_4_s1.c
@@ -0,0 +1,552 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void maxloc1_4_s1 (gfc_array_i4 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(maxloc1_4_s1);
+
+void
+maxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_1 * restrict src;
+ GFC_INTEGER_4 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+ maxval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s1 (gfc_array_i4 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mmaxloc1_4_s1);
+
+void
+mmaxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
+
+ }
+ 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_INTEGER_1 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_4 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+ maxval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ maxval = src;
+ result = (GFC_INTEGER_4)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s1 (gfc_array_i4 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(smaxloc1_4_s1);
+
+void
+smaxloc1_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ maxloc1_4_s1 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
+ }
+ 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_s4.c b/libgfortran/generated/maxloc1_4_s4.c
new file mode 100644
index 00000000000..16b1616f1b5
--- /dev/null
+++ b/libgfortran/generated/maxloc1_4_s4.c
@@ -0,0 +1,552 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void maxloc1_4_s4 (gfc_array_i4 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(maxloc1_4_s4);
+
+void
+maxloc1_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_4 * restrict src;
+ GFC_INTEGER_4 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+ maxval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s4 (gfc_array_i4 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mmaxloc1_4_s4);
+
+void
+mmaxloc1_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
+
+ }
+ 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_INTEGER_4 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_4 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+ maxval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ maxval = src;
+ result = (GFC_INTEGER_4)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s4 (gfc_array_i4 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(smaxloc1_4_s4);
+
+void
+smaxloc1_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ maxloc1_4_s4 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
+ }
+ 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_s1.c b/libgfortran/generated/maxloc1_8_s1.c
new file mode 100644
index 00000000000..f3d8697367e
--- /dev/null
+++ b/libgfortran/generated/maxloc1_8_s1.c
@@ -0,0 +1,552 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void maxloc1_8_s1 (gfc_array_i8 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(maxloc1_8_s1);
+
+void
+maxloc1_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_1 * restrict src;
+ GFC_INTEGER_8 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+ maxval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s1 (gfc_array_i8 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mmaxloc1_8_s1);
+
+void
+mmaxloc1_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
+
+ }
+ 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_INTEGER_1 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_8 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_1 *maxval;
+ maxval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ maxval = src;
+ result = (GFC_INTEGER_8)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s1 (gfc_array_i8 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(smaxloc1_8_s1);
+
+void
+smaxloc1_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ maxloc1_8_s1 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
+ }
+ 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_s4.c b/libgfortran/generated/maxloc1_8_s4.c
new file mode 100644
index 00000000000..bebc1854132
--- /dev/null
+++ b/libgfortran/generated/maxloc1_8_s4.c
@@ -0,0 +1,552 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void maxloc1_8_s4 (gfc_array_i8 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(maxloc1_8_s4);
+
+void
+maxloc1_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_4 * restrict src;
+ GFC_INTEGER_8 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+ maxval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s4 (gfc_array_i8 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mmaxloc1_8_s4);
+
+void
+mmaxloc1_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
+
+ }
+ 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_INTEGER_4 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_8 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_4 *maxval;
+ maxval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ maxval = src;
+ result = (GFC_INTEGER_8)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, maxval, string_len) > 0)
+ {
+ 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_s4 (gfc_array_i8 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(smaxloc1_8_s4);
+
+void
+smaxloc1_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ maxloc1_8_s4 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
+ }
+ 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/maxloc2_16_s1.c b/libgfortran/generated/maxloc2_16_s1.c
new file mode 100644
index 00000000000..7770101e0f7
--- /dev/null
+++ b/libgfortran/generated/maxloc2_16_s1.c
@@ -0,0 +1,156 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_16 maxloc2_16_s1 (gfc_array_s1 * const restrict, int);
+export_proto(maxloc2_16_s1);
+
+GFC_INTEGER_16
+maxloc2_16_s1 (gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_16 mmaxloc2_16_s1 (gfc_array_s1 * const restrict,
+ gfc_array_l1 *const restrict mask, gfc_charlen_type);
+export_proto(mmaxloc2_16_s1);
+
+GFC_INTEGER_16
+mmaxloc2_16_s1 (gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask,
+ gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_16 smaxloc2_16_s1 (gfc_array_s1 * const restrict,
+ GFC_LOGICAL_4 *mask, int);
+export_proto(smaxloc2_16_s1);
+
+GFC_INTEGER_16
+smaxloc2_16_s1 (gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return maxloc2_16_s1 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/maxloc2_16_s4.c b/libgfortran/generated/maxloc2_16_s4.c
new file mode 100644
index 00000000000..327979000fc
--- /dev/null
+++ b/libgfortran/generated/maxloc2_16_s4.c
@@ -0,0 +1,156 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_16 maxloc2_16_s4 (gfc_array_s4 * const restrict, int);
+export_proto(maxloc2_16_s4);
+
+GFC_INTEGER_16
+maxloc2_16_s4 (gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_16 mmaxloc2_16_s4 (gfc_array_s4 * const restrict,
+ gfc_array_l1 *const restrict mask, gfc_charlen_type);
+export_proto(mmaxloc2_16_s4);
+
+GFC_INTEGER_16
+mmaxloc2_16_s4 (gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask,
+ gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_16 smaxloc2_16_s4 (gfc_array_s4 * const restrict,
+ GFC_LOGICAL_4 *mask, int);
+export_proto(smaxloc2_16_s4);
+
+GFC_INTEGER_16
+smaxloc2_16_s4 (gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return maxloc2_16_s4 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/maxloc2_4_s1.c b/libgfortran/generated/maxloc2_4_s1.c
new file mode 100644
index 00000000000..a969fcbac93
--- /dev/null
+++ b/libgfortran/generated/maxloc2_4_s1.c
@@ -0,0 +1,156 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_4 maxloc2_4_s1 (gfc_array_s1 * const restrict, int);
+export_proto(maxloc2_4_s1);
+
+GFC_INTEGER_4
+maxloc2_4_s1 (gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_4 mmaxloc2_4_s1 (gfc_array_s1 * const restrict,
+ gfc_array_l1 *const restrict mask, gfc_charlen_type);
+export_proto(mmaxloc2_4_s1);
+
+GFC_INTEGER_4
+mmaxloc2_4_s1 (gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask,
+ gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_4 smaxloc2_4_s1 (gfc_array_s1 * const restrict,
+ GFC_LOGICAL_4 *mask, int);
+export_proto(smaxloc2_4_s1);
+
+GFC_INTEGER_4
+smaxloc2_4_s1 (gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return maxloc2_4_s1 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/maxloc2_4_s4.c b/libgfortran/generated/maxloc2_4_s4.c
new file mode 100644
index 00000000000..3e9c089e281
--- /dev/null
+++ b/libgfortran/generated/maxloc2_4_s4.c
@@ -0,0 +1,156 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_4 maxloc2_4_s4 (gfc_array_s4 * const restrict, int);
+export_proto(maxloc2_4_s4);
+
+GFC_INTEGER_4
+maxloc2_4_s4 (gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_4 mmaxloc2_4_s4 (gfc_array_s4 * const restrict,
+ gfc_array_l1 *const restrict mask, gfc_charlen_type);
+export_proto(mmaxloc2_4_s4);
+
+GFC_INTEGER_4
+mmaxloc2_4_s4 (gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask,
+ gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_4 smaxloc2_4_s4 (gfc_array_s4 * const restrict,
+ GFC_LOGICAL_4 *mask, int);
+export_proto(smaxloc2_4_s4);
+
+GFC_INTEGER_4
+smaxloc2_4_s4 (gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return maxloc2_4_s4 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/maxloc2_8_s1.c b/libgfortran/generated/maxloc2_8_s1.c
new file mode 100644
index 00000000000..bb84ff40461
--- /dev/null
+++ b/libgfortran/generated/maxloc2_8_s1.c
@@ -0,0 +1,156 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_8 maxloc2_8_s1 (gfc_array_s1 * const restrict, int);
+export_proto(maxloc2_8_s1);
+
+GFC_INTEGER_8
+maxloc2_8_s1 (gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_8 mmaxloc2_8_s1 (gfc_array_s1 * const restrict,
+ gfc_array_l1 *const restrict mask, gfc_charlen_type);
+export_proto(mmaxloc2_8_s1);
+
+GFC_INTEGER_8
+mmaxloc2_8_s1 (gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask,
+ gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_8 smaxloc2_8_s1 (gfc_array_s1 * const restrict,
+ GFC_LOGICAL_4 *mask, int);
+export_proto(smaxloc2_8_s1);
+
+GFC_INTEGER_8
+smaxloc2_8_s1 (gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return maxloc2_8_s1 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/maxloc2_8_s4.c b/libgfortran/generated/maxloc2_8_s4.c
new file mode 100644
index 00000000000..1aa67ca391c
--- /dev/null
+++ b/libgfortran/generated/maxloc2_8_s4.c
@@ -0,0 +1,156 @@
+/* Implementation of the MAXLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_8 maxloc2_8_s4 (gfc_array_s4 * const restrict, int);
+export_proto(maxloc2_8_s4);
+
+GFC_INTEGER_8
+maxloc2_8_s4 (gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_8 mmaxloc2_8_s4 (gfc_array_s4 * const restrict,
+ gfc_array_l1 *const restrict mask, gfc_charlen_type);
+export_proto(mmaxloc2_8_s4);
+
+GFC_INTEGER_8
+mmaxloc2_8_s4 (gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask,
+ gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) > 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_8 smaxloc2_8_s4 (gfc_array_s4 * const restrict,
+ GFC_LOGICAL_4 *mask, int);
+export_proto(smaxloc2_8_s4);
+
+GFC_INTEGER_8
+smaxloc2_8_s4 (gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return maxloc2_8_s4 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/minloc0_16_s1.c b/libgfortran/generated/minloc0_16_s1.c
new file mode 100644
index 00000000000..e43feaf2c4e
--- /dev/null
+++ b/libgfortran/generated/minloc0_16_s1.c
@@ -0,0 +1,327 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void minloc0_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len);
+export_proto(minloc0_16_s1);
+
+void
+minloc0_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *minval;
+ minval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, minval, len) < 0)
+ {
+ 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_s1 (gfc_array_i16 * const restrict,
+ gfc_array_s1 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mminloc0_16_s1);
+
+void
+mminloc0_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_1 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *minval;
+
+ minval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (minval == NULL || compare_fcn (base, minval, len) < 0))
+ {
+ 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_s1 (gfc_array_i16 * const restrict,
+ gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(sminloc0_16_s1);
+
+void
+sminloc0_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_16 *dest;
+
+ if (*mask)
+ {
+ minloc0_16_s1 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/minloc0_16_s4.c b/libgfortran/generated/minloc0_16_s4.c
new file mode 100644
index 00000000000..9e1ba354b5c
--- /dev/null
+++ b/libgfortran/generated/minloc0_16_s4.c
@@ -0,0 +1,327 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void minloc0_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len);
+export_proto(minloc0_16_s4);
+
+void
+minloc0_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *minval;
+ minval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, minval, len) < 0)
+ {
+ 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_s4 (gfc_array_i16 * const restrict,
+ gfc_array_s4 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mminloc0_16_s4);
+
+void
+mminloc0_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_4 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *minval;
+
+ minval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (minval == NULL || compare_fcn (base, minval, len) < 0))
+ {
+ 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_s4 (gfc_array_i16 * const restrict,
+ gfc_array_s4 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(sminloc0_16_s4);
+
+void
+sminloc0_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_16 *dest;
+
+ if (*mask)
+ {
+ minloc0_16_s4 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/minloc0_4_s1.c b/libgfortran/generated/minloc0_4_s1.c
new file mode 100644
index 00000000000..ab95a83ecd6
--- /dev/null
+++ b/libgfortran/generated/minloc0_4_s1.c
@@ -0,0 +1,327 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void minloc0_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len);
+export_proto(minloc0_4_s1);
+
+void
+minloc0_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *minval;
+ minval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, minval, len) < 0)
+ {
+ 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_s1 (gfc_array_i4 * const restrict,
+ gfc_array_s1 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mminloc0_4_s1);
+
+void
+mminloc0_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_1 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *minval;
+
+ minval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (minval == NULL || compare_fcn (base, minval, len) < 0))
+ {
+ 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_s1 (gfc_array_i4 * const restrict,
+ gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(sminloc0_4_s1);
+
+void
+sminloc0_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_4 *dest;
+
+ if (*mask)
+ {
+ minloc0_4_s1 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/minloc0_4_s4.c b/libgfortran/generated/minloc0_4_s4.c
new file mode 100644
index 00000000000..4afe02e5ed2
--- /dev/null
+++ b/libgfortran/generated/minloc0_4_s4.c
@@ -0,0 +1,327 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void minloc0_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len);
+export_proto(minloc0_4_s4);
+
+void
+minloc0_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *minval;
+ minval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, minval, len) < 0)
+ {
+ 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_s4 (gfc_array_i4 * const restrict,
+ gfc_array_s4 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mminloc0_4_s4);
+
+void
+mminloc0_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_4 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *minval;
+
+ minval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (minval == NULL || compare_fcn (base, minval, len) < 0))
+ {
+ 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_s4 (gfc_array_i4 * const restrict,
+ gfc_array_s4 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(sminloc0_4_s4);
+
+void
+sminloc0_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_4 *dest;
+
+ if (*mask)
+ {
+ minloc0_4_s4 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/minloc0_8_s1.c b/libgfortran/generated/minloc0_8_s1.c
new file mode 100644
index 00000000000..0dc18feb8ec
--- /dev/null
+++ b/libgfortran/generated/minloc0_8_s1.c
@@ -0,0 +1,327 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void minloc0_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len);
+export_proto(minloc0_8_s1);
+
+void
+minloc0_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *minval;
+ minval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, minval, len) < 0)
+ {
+ 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_s1 (gfc_array_i8 * const restrict,
+ gfc_array_s1 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mminloc0_8_s1);
+
+void
+mminloc0_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_1 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_1 *minval;
+
+ minval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (minval == NULL || compare_fcn (base, minval, len) < 0))
+ {
+ 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_s1 (gfc_array_i8 * const restrict,
+ gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(sminloc0_8_s1);
+
+void
+sminloc0_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_8 *dest;
+
+ if (*mask)
+ {
+ minloc0_8_s1 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/minloc0_8_s4.c b/libgfortran/generated/minloc0_8_s4.c
new file mode 100644
index 00000000000..bd847889bc7
--- /dev/null
+++ b/libgfortran/generated/minloc0_8_s4.c
@@ -0,0 +1,327 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <limits.h>
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+
+}
+
+extern void minloc0_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len);
+export_proto(minloc0_8_s4);
+
+void
+minloc0_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type sstride[GFC_MAX_DIMENSIONS];
+ index_type dstride;
+ const GFC_INTEGER_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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *minval;
+ minval = base;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (compare_fcn (base, minval, len) < 0)
+ {
+ 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_s4 (gfc_array_i8 * const restrict,
+ gfc_array_s4 * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(mminloc0_8_s4);
+
+void
+mminloc0_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ 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_INTEGER_4 *base;
+ GFC_LOGICAL_1 *mbase;
+ int rank;
+ index_type n;
+ int mask_kind;
+
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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) * len;
+ 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;
+ {
+
+ const GFC_INTEGER_4 *minval;
+
+ minval = NULL;
+
+ while (base)
+ {
+ do
+ {
+ /* Implementation start. */
+
+ if (*mbase && (minval == NULL || compare_fcn (base, minval, len) < 0))
+ {
+ 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_s4 (gfc_array_i8 * const restrict,
+ gfc_array_s4 * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(sminloc0_8_s4);
+
+void
+sminloc0_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+ index_type rank;
+ index_type dstride;
+ index_type n;
+ GFC_INTEGER_8 *dest;
+
+ if (*mask)
+ {
+ minloc0_8_s4 (retarray, array, len);
+ 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 = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 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++)
+ dest[n * dstride] = 0 ;
+}
+#endif
diff --git a/libgfortran/generated/minloc1_16_s1.c b/libgfortran/generated/minloc1_16_s1.c
new file mode 100644
index 00000000000..80269a6c495
--- /dev/null
+++ b/libgfortran/generated/minloc1_16_s1.c
@@ -0,0 +1,552 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void minloc1_16_s1 (gfc_array_i16 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(minloc1_16_s1);
+
+void
+minloc1_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_1 * restrict src;
+ GFC_INTEGER_16 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_1 *minval;
+ minval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s1 (gfc_array_i16 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mminloc1_16_s1);
+
+void
+mminloc1_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
+
+ }
+ 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_INTEGER_1 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_16 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_1 *minval;
+ minval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ minval = src;
+ result = (GFC_INTEGER_16)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s1 (gfc_array_i16 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(sminloc1_16_s1);
+
+void
+sminloc1_16_s1 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ minloc1_16_s1 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
+ }
+ 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_s4.c b/libgfortran/generated/minloc1_16_s4.c
new file mode 100644
index 00000000000..1ba1a011b09
--- /dev/null
+++ b/libgfortran/generated/minloc1_16_s4.c
@@ -0,0 +1,552 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void minloc1_16_s4 (gfc_array_i16 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(minloc1_16_s4);
+
+void
+minloc1_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_4 * restrict src;
+ GFC_INTEGER_16 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_4 *minval;
+ minval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s4 (gfc_array_i16 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mminloc1_16_s4);
+
+void
+mminloc1_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
+
+ }
+ 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_INTEGER_4 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_16 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_4 *minval;
+ minval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ minval = src;
+ result = (GFC_INTEGER_16)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s4 (gfc_array_i16 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(sminloc1_16_s4);
+
+void
+sminloc1_16_s4 (gfc_array_i16 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ minloc1_16_s4 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
+ }
+ 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_s1.c b/libgfortran/generated/minloc1_4_s1.c
new file mode 100644
index 00000000000..bbead6b8833
--- /dev/null
+++ b/libgfortran/generated/minloc1_4_s1.c
@@ -0,0 +1,552 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void minloc1_4_s1 (gfc_array_i4 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(minloc1_4_s1);
+
+void
+minloc1_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_1 * restrict src;
+ GFC_INTEGER_4 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_1 *minval;
+ minval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s1 (gfc_array_i4 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mminloc1_4_s1);
+
+void
+mminloc1_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
+
+ }
+ 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_INTEGER_1 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_4 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_1 *minval;
+ minval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ minval = src;
+ result = (GFC_INTEGER_4)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s1 (gfc_array_i4 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(sminloc1_4_s1);
+
+void
+sminloc1_4_s1 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ minloc1_4_s1 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
+ }
+ 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_s4.c b/libgfortran/generated/minloc1_4_s4.c
new file mode 100644
index 00000000000..673702b6e5a
--- /dev/null
+++ b/libgfortran/generated/minloc1_4_s4.c
@@ -0,0 +1,552 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void minloc1_4_s4 (gfc_array_i4 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(minloc1_4_s4);
+
+void
+minloc1_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_4 * restrict src;
+ GFC_INTEGER_4 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_4 *minval;
+ minval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s4 (gfc_array_i4 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mminloc1_4_s4);
+
+void
+mminloc1_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
+
+ }
+ 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_INTEGER_4 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_4 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_4 *minval;
+ minval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ minval = src;
+ result = (GFC_INTEGER_4)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s4 (gfc_array_i4 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(sminloc1_4_s4);
+
+void
+sminloc1_4_s4 (gfc_array_i4 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ minloc1_4_s4 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
+ }
+ 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_s1.c b/libgfortran/generated/minloc1_8_s1.c
new file mode 100644
index 00000000000..90ab35324a2
--- /dev/null
+++ b/libgfortran/generated/minloc1_8_s1.c
@@ -0,0 +1,552 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void minloc1_8_s1 (gfc_array_i8 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(minloc1_8_s1);
+
+void
+minloc1_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_1 * restrict src;
+ GFC_INTEGER_8 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_1 *minval;
+ minval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s1 (gfc_array_i8 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mminloc1_8_s1);
+
+void
+mminloc1_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
+
+ }
+ 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_INTEGER_1 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_8 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_1 *minval;
+ minval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ minval = src;
+ result = (GFC_INTEGER_8)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s1 (gfc_array_i8 * const restrict,
+ gfc_array_s1 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(sminloc1_8_s1);
+
+void
+sminloc1_8_s1 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s1 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ minloc1_8_s1 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
+ }
+ 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_s4.c b/libgfortran/generated/minloc1_8_s4.c
new file mode 100644
index 00000000000..10c02083a94
--- /dev/null
+++ b/libgfortran/generated/minloc1_8_s4.c
@@ -0,0 +1,552 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
+
+#include <string.h>
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, gfc_charlen_type n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern void minloc1_8_s4 (gfc_array_i8 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_charlen_type);
+export_proto(minloc1_8_s4);
+
+void
+minloc1_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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) * string_len;
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ 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_INTEGER_4 * restrict src;
+ GFC_INTEGER_8 result;
+ src = base;
+ {
+
+ const GFC_INTEGER_4 *minval;
+ minval = base;
+ result = 1;
+ if (len <= 0)
+ *dest = 0;
+ else
+ {
+ for (n = 0; n < len; n++, src += delta)
+ {
+
+ if (compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s4 (gfc_array_i8 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(mminloc1_8_s4);
+
+void
+mminloc1_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
+{
+ 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_INTEGER_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;
+
+ 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)
+ return;
+
+ 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) * string_len;
+ mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
+
+ for (n = 0; n < dim; n++)
+ {
+ sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
+ 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) * string_len;
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
+
+ }
+ 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_INTEGER_4 * restrict src;
+ const GFC_LOGICAL_1 * restrict msrc;
+ GFC_INTEGER_8 result;
+ src = base;
+ msrc = mbase;
+ {
+
+ const GFC_INTEGER_4 *minval;
+ minval = base;
+ result = 0;
+ for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+ {
+
+ if (*msrc)
+ {
+ minval = src;
+ result = (GFC_INTEGER_8)n + 1;
+ break;
+ }
+ }
+ for (; n < len; n++, src += delta, msrc += mdelta)
+ {
+ if (*msrc && compare_fcn (src, minval, string_len) < 0)
+ {
+ 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_s4 (gfc_array_i8 * const restrict,
+ gfc_array_s4 * const restrict, const index_type * const restrict,
+ GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(sminloc1_8_s4);
+
+void
+sminloc1_8_s4 (gfc_array_i8 * const restrict retarray,
+ gfc_array_s4 * const restrict array,
+ const index_type * const restrict pdim,
+ GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
+{
+ 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)
+ {
+ minloc1_8_s4 (retarray, array, pdim, string_len);
+ 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) * string_len;
+
+ if (extent[n] <= 0)
+ extent[n] = 0;
+ }
+
+ for (n = dim; n < rank; n++)
+ {
+ extent[n] =
+ GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
+
+ 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
+
+ alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
+
+ if (alloc_size == 0)
+ {
+ /* Make sure we have a zero-sized array. */
+ GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
+ return;
+ }
+ else
+ retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
+ }
+ 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/minloc2_16_s1.c b/libgfortran/generated/minloc2_16_s1.c
new file mode 100644
index 00000000000..3f9e907f84d
--- /dev/null
+++ b/libgfortran/generated/minloc2_16_s1.c
@@ -0,0 +1,155 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_16)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_16 minloc2_16_s1 (gfc_array_s1 * const restrict, int);
+export_proto(minloc2_16_s1);
+
+GFC_INTEGER_16
+minloc2_16_s1 (gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_16 mminloc2_16_s1 (gfc_array_s1 * const restrict,
+ gfc_array_l1 *const restrict mask, int);
+export_proto(mminloc2_16_s1);
+
+GFC_INTEGER_16
+mminloc2_16_s1 (gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_16 sminloc2_16_s1 (gfc_array_s1 * const restrict,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type);
+export_proto(sminloc2_16_s1);
+
+GFC_INTEGER_16
+sminloc2_16_s1 (gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return minloc2_16_s1 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/minloc2_16_s4.c b/libgfortran/generated/minloc2_16_s4.c
new file mode 100644
index 00000000000..4857b08832c
--- /dev/null
+++ b/libgfortran/generated/minloc2_16_s4.c
@@ -0,0 +1,155 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_16)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_16 minloc2_16_s4 (gfc_array_s4 * const restrict, int);
+export_proto(minloc2_16_s4);
+
+GFC_INTEGER_16
+minloc2_16_s4 (gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_16 mminloc2_16_s4 (gfc_array_s4 * const restrict,
+ gfc_array_l1 *const restrict mask, int);
+export_proto(mminloc2_16_s4);
+
+GFC_INTEGER_16
+mminloc2_16_s4 (gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_16 sminloc2_16_s4 (gfc_array_s4 * const restrict,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type);
+export_proto(sminloc2_16_s4);
+
+GFC_INTEGER_16
+sminloc2_16_s4 (gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return minloc2_16_s4 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/minloc2_4_s1.c b/libgfortran/generated/minloc2_4_s1.c
new file mode 100644
index 00000000000..2fd526df0b8
--- /dev/null
+++ b/libgfortran/generated/minloc2_4_s1.c
@@ -0,0 +1,155 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_4 minloc2_4_s1 (gfc_array_s1 * const restrict, int);
+export_proto(minloc2_4_s1);
+
+GFC_INTEGER_4
+minloc2_4_s1 (gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_4 mminloc2_4_s1 (gfc_array_s1 * const restrict,
+ gfc_array_l1 *const restrict mask, int);
+export_proto(mminloc2_4_s1);
+
+GFC_INTEGER_4
+mminloc2_4_s1 (gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_4 sminloc2_4_s1 (gfc_array_s1 * const restrict,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type);
+export_proto(sminloc2_4_s1);
+
+GFC_INTEGER_4
+sminloc2_4_s1 (gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return minloc2_4_s1 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/minloc2_4_s4.c b/libgfortran/generated/minloc2_4_s4.c
new file mode 100644
index 00000000000..ad85d266fe2
--- /dev/null
+++ b/libgfortran/generated/minloc2_4_s4.c
@@ -0,0 +1,155 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_4 minloc2_4_s4 (gfc_array_s4 * const restrict, int);
+export_proto(minloc2_4_s4);
+
+GFC_INTEGER_4
+minloc2_4_s4 (gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_4 mminloc2_4_s4 (gfc_array_s4 * const restrict,
+ gfc_array_l1 *const restrict mask, int);
+export_proto(mminloc2_4_s4);
+
+GFC_INTEGER_4
+mminloc2_4_s4 (gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_4 sminloc2_4_s4 (gfc_array_s4 * const restrict,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type);
+export_proto(sminloc2_4_s4);
+
+GFC_INTEGER_4
+sminloc2_4_s4 (gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return minloc2_4_s4 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/minloc2_8_s1.c b/libgfortran/generated/minloc2_8_s1.c
new file mode 100644
index 00000000000..0b594d6c6c6
--- /dev/null
+++ b/libgfortran/generated/minloc2_8_s1.c
@@ -0,0 +1,155 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
+
+static inline int
+compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_1) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_8 minloc2_8_s1 (gfc_array_s1 * const restrict, int);
+export_proto(minloc2_8_s1);
+
+GFC_INTEGER_8
+minloc2_8_s1 (gfc_array_s1 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_8 mminloc2_8_s1 (gfc_array_s1 * const restrict,
+ gfc_array_l1 *const restrict mask, int);
+export_proto(mminloc2_8_s1);
+
+GFC_INTEGER_8
+mminloc2_8_s1 (gfc_array_s1 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_1 *src;
+ const GFC_INTEGER_1 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_8 sminloc2_8_s1 (gfc_array_s1 * const restrict,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type);
+export_proto(sminloc2_8_s1);
+
+GFC_INTEGER_8
+sminloc2_8_s1 (gfc_array_s1 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return minloc2_8_s1 (array, len);
+ else
+ return 0;
+}
+
+#endif
diff --git a/libgfortran/generated/minloc2_8_s4.c b/libgfortran/generated/minloc2_8_s4.c
new file mode 100644
index 00000000000..71a55fcfba2
--- /dev/null
+++ b/libgfortran/generated/minloc2_8_s4.c
@@ -0,0 +1,155 @@
+/* Implementation of the MINLOC intrinsic
+ Copyright 2017 Free Software Foundation, Inc.
+ Contributed by Thomas Koenig
+
+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
+<http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+
+#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
+
+static inline int
+compare_fcn (const GFC_INTEGER_4 *a, const GFC_INTEGER_4 *b, int n)
+{
+ if (sizeof (GFC_INTEGER_4) == 1)
+ return memcmp (a, b, n);
+ else
+ return memcmp_char4 (a, b, n);
+}
+
+extern GFC_INTEGER_8 minloc2_8_s4 (gfc_array_s4 * const restrict, int);
+export_proto(minloc2_8_s4);
+
+GFC_INTEGER_8
+minloc2_8_s4 (gfc_array_s4 * const restrict array, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ ret = 1;
+ src = array->base_addr;
+ maxval = src;
+ for (i=2; i<=extent; i++)
+ {
+ src += sstride;
+ if (compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_8 mminloc2_8_s4 (gfc_array_s4 * const restrict,
+ gfc_array_l1 *const restrict mask, int);
+export_proto(mminloc2_8_s4);
+
+GFC_INTEGER_8
+mminloc2_8_s4 (gfc_array_s4 * const restrict array,
+ gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+ index_type ret;
+ index_type sstride;
+ index_type extent;
+ const GFC_INTEGER_4 *src;
+ const GFC_INTEGER_4 *maxval;
+ index_type i, j;
+ GFC_LOGICAL_1 *mbase;
+ int mask_kind;
+ index_type mstride;
+
+ extent = GFC_DESCRIPTOR_EXTENT(array,0);
+ if (extent <= 0)
+ return 0;
+
+ sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
+
+ 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
+ internal_error (NULL, "Funny sized logical array");
+
+ mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
+
+ /* Search for the first occurrence of a true element in mask. */
+ for (j=0; j<extent; j++)
+ {
+ if (*mbase)
+ break;
+ mbase += mstride;
+ }
+
+ if (j == extent)
+ return 0;
+
+ ret = j + 1;
+ src = array->base_addr + j * sstride;
+ maxval = src;
+
+ for (i=j+1; i<=extent; i++)
+ {
+ if (*mbase && compare_fcn (src, maxval, len) < 0)
+ {
+ ret = i;
+ maxval = src;
+ }
+ src += sstride;
+ mbase += mstride;
+ }
+ return ret;
+}
+
+extern GFC_INTEGER_8 sminloc2_8_s4 (gfc_array_s4 * const restrict,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type);
+export_proto(sminloc2_8_s4);
+
+GFC_INTEGER_8
+sminloc2_8_s4 (gfc_array_s4 * const restrict array,
+ GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+ if (mask)
+ return minloc2_8_s4 (array, len);
+ else
+ return 0;
+}
+
+#endif