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

10 files changed, 1385 insertions, 2 deletions

diff --git a/libgfortran/m4/iforeach-s.m4 b/libgfortran/m4/iforeach-s.m4
new file mode 100644
index 00000000000..39868ddf3ee
--- /dev/null
+++ b/libgfortran/m4/iforeach-s.m4
@@ -0,0 +1,288 @@
+dnl Support macro file for intrinsic functions.
+dnl Contains the generic sections of the array functions.
+dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
+dnl Distributed under the GNU GPL with exception.  See COPYING for details.
+define(START_FOREACH_FUNCTION,
+`static inline int
+compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
+{
+  if (sizeof ('atype_name`) == 1)
+    return memcmp (a, b, n);
+  else
+    return memcmp_char4 (a, b, n);
+
+}
+
+extern void name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
+	atype * const restrict array, gfc_charlen_type len);
+export_proto(name`'rtype_qual`_'atype_code);
+
+void
+name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
+	atype * 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 atype_name *base;
+  rtype_name * 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 (rtype_name));
+    }
+  else
+    {
+      if (unlikely (compile_options.bounds_check))
+	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
+				"u_name");
+    }
+
+  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;
+  {
+')dnl
+define(START_FOREACH_BLOCK,
+`  while (base)
+    {
+      do
+	{
+	  /* Implementation start.  */
+')dnl
+define(FINISH_FOREACH_FUNCTION,
+`	  /* 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]);
+    }
+  }
+}')dnl
+define(START_MASKED_FOREACH_FUNCTION,
+`
+extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, 
+	atype * const restrict, gfc_array_l1 * const restrict, gfc_charlen_type len);
+export_proto(`m'name`'rtype_qual`_'atype_code);
+
+void
+`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
+	atype * 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;
+  rtype_name *dest;
+  const atype_name *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 (rtype_name));
+    }
+  else
+    {
+      if (unlikely (compile_options.bounds_check))
+	{
+
+	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
+				  "u_name");
+	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
+				  "MASK argument", "u_name");
+	}
+    }
+
+  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;
+  {
+')dnl
+define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
+define(FINISH_MASKED_FOREACH_FUNCTION,
+`	  /* 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]);
+    }
+  }
+}')dnl
+define(FOREACH_FUNCTION,
+`START_FOREACH_FUNCTION
+$1
+START_FOREACH_BLOCK
+$2
+FINISH_FOREACH_FUNCTION')dnl
+define(MASKED_FOREACH_FUNCTION,
+`START_MASKED_FOREACH_FUNCTION
+$1
+START_MASKED_FOREACH_BLOCK
+$2
+FINISH_MASKED_FOREACH_FUNCTION')dnl
+define(SCALAR_FOREACH_FUNCTION,
+`
+extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, 
+	atype * const restrict, GFC_LOGICAL_4 *, gfc_charlen_type len);
+export_proto(`s'name`'rtype_qual`_'atype_code);
+
+void
+`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
+	atype * const restrict array,
+	GFC_LOGICAL_4 * mask, gfc_charlen_type len)
+{
+  index_type rank;
+  index_type dstride;
+  index_type n;
+  rtype_name *dest;
+
+  if (*mask)
+    {
+      name`'rtype_qual`_'atype_code (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 (rtype_name));
+    }
+  else if (unlikely (compile_options.bounds_check))
+    {
+       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
+			       "u_name");
+    }
+
+  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
+  dest = retarray->base_addr;
+  for (n = 0; n<rank; n++)
+    dest[n * dstride] = $1 ;
+}')dnl
diff --git a/libgfortran/m4/ifunction-s.m4 b/libgfortran/m4/ifunction-s.m4
new file mode 100644
index 00000000000..93ca694c826
--- /dev/null
+++ b/libgfortran/m4/ifunction-s.m4
@@ -0,0 +1,530 @@
+dnl Support macro file for intrinsic functions.
+dnl Contains the generic sections of the array functions.
+dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
+dnl Distributed under the GNU GPL with exception.  See COPYING for details.
+dnl
+dnl Pass the implementation for a single section as the parameter to
+dnl {MASK_}ARRAY_FUNCTION.
+dnl The variables base, delta, and len describe the input section.
+dnl For masked section the mask is described by mbase and mdelta.
+dnl These should not be modified. The result should be stored in *dest.
+dnl The names count, extent, sstride, dstride, base, dest, rank, dim
+dnl retarray, array, pdim and mstride should not be used.
+dnl The variable n is declared as index_type and may be used.
+dnl Other variable declarations may be placed at the start of the code,
+dnl The types of the array parameter and the return value are
+dnl atype_name and rtype_name respectively.
+dnl Execution should be allowed to continue to the end of the block.
+dnl You should not return or break from the inner loop of the implementation.
+dnl Care should also be taken to avoid using the names defined in iparm.m4
+define(START_ARRAY_FUNCTION,
+`#include <string.h>
+
+static inline int
+compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n)
+{
+  if (sizeof ('atype_name`) == 1)
+    return memcmp (a, b, n);
+  else
+    return memcmp_char4 (a, b, n);
+}
+
+extern void name`'rtype_qual`_'atype_code (rtype * const restrict, 
+	atype * const restrict, const index_type * const restrict,
+	gfc_charlen_type);
+export_proto(name`'rtype_qual`_'atype_code);
+
+void
+name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
+	atype * 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 atype_name * restrict base;
+  rtype_name * 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 u_name 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 (rtype_name));
+      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"
+		       " u_name 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", "u_name");
+    }
+
+  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 atype_name * restrict src;
+      rtype_name result;
+      src = base;
+      {
+')dnl
+define(START_ARRAY_BLOCK,
+`	if (len <= 0)
+	  *dest = '$1`;
+	else
+	  {
+	    for (n = 0; n < len; n++, src += delta)
+	      {
+')dnl
+define(FINISH_ARRAY_FUNCTION,
+`	      }
+	    '$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];
+	    }
+	}
+    }
+}')dnl
+define(START_MASKED_ARRAY_FUNCTION,
+`
+extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, 
+	atype * const restrict, const index_type * const restrict,
+	gfc_array_l1 * const restrict, gfc_charlen_type);
+export_proto(`m'name`'rtype_qual`_'atype_code);
+
+void
+`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
+	atype * 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];
+  rtype_name * restrict dest;
+  const atype_name * 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 u_name 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 (rtype_name));
+
+    }
+  else
+    {
+      if (rank != GFC_DESCRIPTOR_RANK (retarray))
+	runtime_error ("rank of return array incorrect in u_name intrinsic");
+
+      if (unlikely (compile_options.bounds_check))
+	{
+	  bounds_ifunction_return ((array_t *) retarray, extent,
+				   "return value", "u_name");
+	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
+	  			"MASK argument", "u_name");
+	}
+    }
+
+  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 atype_name * restrict src;
+      const GFC_LOGICAL_1 * restrict msrc;
+      rtype_name result;
+      src = base;
+      msrc = mbase;
+      {
+')dnl
+define(START_MASKED_ARRAY_BLOCK,
+`	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
+	  {
+')dnl
+define(FINISH_MASKED_ARRAY_FUNCTION,
+`	  }
+	*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];
+	    }
+	}
+    }
+}')dnl
+define(SCALAR_ARRAY_FUNCTION,
+`
+extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, 
+	atype * const restrict, const index_type * const restrict,
+	GFC_LOGICAL_4 *, gfc_charlen_type);
+export_proto(`s'name`'rtype_qual`_'atype_code);
+
+void
+`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, 
+	atype * 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];
+  rtype_name * restrict dest;
+  index_type rank;
+  index_type n;
+  index_type dim;
+
+
+  if (*mask)
+    {
+      name`'rtype_qual`_'atype_code (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 u_name 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 (rtype_name));
+    }
+  else
+    {
+      if (rank != GFC_DESCRIPTOR_RANK (retarray))
+	runtime_error ("rank of return array incorrect in"
+		       " u_name 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"
+			       " u_name 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 = '$1`;
+      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];
+	    }
+      	}
+    }
+}')dnl
+define(ARRAY_FUNCTION,
+`START_ARRAY_FUNCTION
+$2
+START_ARRAY_BLOCK($1)
+$3
+FINISH_ARRAY_FUNCTION($4)')dnl
+define(MASKED_ARRAY_FUNCTION,
+`START_MASKED_ARRAY_FUNCTION
+$2
+START_MASKED_ARRAY_BLOCK
+$3
+FINISH_MASKED_ARRAY_FUNCTION')dnl
diff --git a/libgfortran/m4/ifunction.m4 b/libgfortran/m4/ifunction.m4
index 91cfd28d5d1..7777a0c8c07 100644
--- a/libgfortran/m4/ifunction.m4
+++ b/libgfortran/m4/ifunction.m4
@@ -42,8 +42,8 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
   int continue_loop;
 
   /* Make dim zero based to avoid confusion.  */
-  dim = (*pdim) - 1;
   rank = GFC_DESCRIPTOR_RANK (array) - 1;
+  dim = (*pdim) - 1;
 
   if (unlikely (dim < 0 || dim > rank))
     {
diff --git a/libgfortran/m4/iparm.m4 b/libgfortran/m4/iparm.m4
index 4ff62474107..4bf2a3010cf 100644
--- a/libgfortran/m4/iparm.m4
+++ b/libgfortran/m4/iparm.m4
@@ -4,7 +4,7 @@ dnl This file is part of the GNU Fortran 95 Runtime Library (libgfortran)
 dnl Distributed under the GNU GPL with exception.  See COPYING for details.
 dnl M4 macro file to get type names from filenames
 define(get_typename2, `GFC_$1_$2')dnl
-define(get_typename, `get_typename2(ifelse($1,i,INTEGER,ifelse($1,r,REAL,ifelse($1,l,LOGICAL,ifelse($1,c,COMPLEX,unknown)))),`$2')')dnl
+define(get_typename, `get_typename2(ifelse($1,i,INTEGER,ifelse($1,r,REAL,ifelse($1,l,LOGICAL,ifelse($1,c,COMPLEX,ifelse($1,s,INTEGER,unknown))))),`$2')')dnl
 define(get_arraytype, `gfc_array_$1$2')dnl
 define(define_type, `dnl
 ifelse(regexp($2,`^[0-9]'),-1,`dnl
diff --git a/libgfortran/m4/maxloc0s.m4 b/libgfortran/m4/maxloc0s.m4
new file mode 100644
index 00000000000..96935dc72c0
--- /dev/null
+++ b/libgfortran/m4/maxloc0s.m4
@@ -0,0 +1,61 @@
+`/* 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>'
+
+include(iparm.m4)dnl
+include(iforeach-s.m4)dnl
+
+`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
+
+FOREACH_FUNCTION(
+`  const atype_name *maxval;
+   maxval = base;'
+,
+`  if (compare_fcn (base, maxval, len) > 0)
+    {
+      maxval = base;
+      for (n = 0; n < rank; n++)
+        dest[n * dstride] = count[n] + 1;
+    }')
+
+MASKED_FOREACH_FUNCTION(
+`  const atype_name *maxval;
+
+  maxval = NULL;'
+,
+`  if (*mbase && (maxval == NULL || compare_fcn (base, maxval, len) > 0))
+    {
+      maxval = base;
+      for (n = 0; n < rank; n++)
+        dest[n * dstride] = count[n] + 1;
+    }')
+
+SCALAR_FOREACH_FUNCTION(`0')
+#endif
diff --git a/libgfortran/m4/maxloc1s.m4 b/libgfortran/m4/maxloc1s.m4
new file mode 100644
index 00000000000..dbb69b47589
--- /dev/null
+++ b/libgfortran/m4/maxloc1s.m4
@@ -0,0 +1,65 @@
+`/* 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(iparm.m4)dnl
+include(ifunction-s.m4)dnl
+
+`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
+
+ARRAY_FUNCTION(0,
+`	const atype_name *maxval;
+	maxval = base;
+	result = 1;',
+`		if (compare_fcn (src, maxval, string_len) > 0)
+		  {
+		    maxval = src;
+		    result = (rtype_name)n + 1;
+		  }', `')
+
+MASKED_ARRAY_FUNCTION(0,
+`	const atype_name *maxval;
+	maxval = base;
+	result = 0;',
+`		if (*msrc)
+		      {
+			maxval = src;
+			result = (rtype_name)n + 1;
+			break;
+		      }
+	    }
+	    for (; n < len; n++, src += delta, msrc += mdelta)
+	      {
+		if (*msrc && compare_fcn (src, maxval, string_len) > 0)
+		  {
+		    maxval = src;
+		    result = (rtype_name)n + 1;
+		  }
+	      ')
+
+SCALAR_ARRAY_FUNCTION(0)
+
+#endif
diff --git a/libgfortran/m4/maxloc2s.m4 b/libgfortran/m4/maxloc2s.m4
new file mode 100644
index 00000000000..9b2ed740aca
--- /dev/null
+++ b/libgfortran/m4/maxloc2s.m4
@@ -0,0 +1,157 @@
+`/* 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(iparm.m4)dnl
+
+`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)
+
+static inline int
+compare_fcn (const 'atype_name` *a, const 'atype_name` *b, int n)
+{
+  if (sizeof ('atype_name`) == 1)
+    return memcmp (a, b, n);
+  else
+    return memcmp_char4 (a, b, n);
+}
+
+extern 'rtype_name` 'name`'rtype_qual`_'atype_code` ('atype` * const restrict, int);
+export_proto('name`'rtype_qual`_'atype_code`);
+
+'rtype_name`
+'name`'rtype_qual`_'atype_code` ('atype` * const restrict array, gfc_charlen_type len)
+{
+  index_type ret;
+  index_type sstride;
+  index_type extent;
+  const 'atype_name` *src;
+  const 'atype_name` *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 'rtype_name` m'name`'rtype_qual`_'atype_code` ('atype` * const restrict,
+       		    	gfc_array_l1 *const restrict mask, gfc_charlen_type);
+export_proto(m'name`'rtype_qual`_'atype_code`);
+
+'rtype_name`
+m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
+				 gfc_array_l1 * const restrict mask,
+				 gfc_charlen_type len)
+{
+  index_type ret;
+  index_type sstride;
+  index_type extent;
+  const 'atype_name` *src;
+  const 'atype_name` *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 'rtype_name` s'name`'rtype_qual`_'atype_code` ('atype` * const restrict,
+       		    	GFC_LOGICAL_4 *mask, int);
+export_proto(s'name`'rtype_qual`_'atype_code`);
+
+'rtype_name`
+s'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
+				 GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+  if (mask)
+    return 'name`'rtype_qual`_'atype_code` (array, len);
+  else
+    return 0;
+}
+
+#endif'
diff --git a/libgfortran/m4/minloc0s.m4 b/libgfortran/m4/minloc0s.m4
new file mode 100644
index 00000000000..b907be3d993
--- /dev/null
+++ b/libgfortran/m4/minloc0s.m4
@@ -0,0 +1,61 @@
+`/* 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>'
+
+include(iparm.m4)dnl
+include(iforeach-s.m4)dnl
+
+`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
+
+FOREACH_FUNCTION(
+`  const atype_name *minval;
+   minval = base;'
+,
+`  if (compare_fcn (base, minval, len) < 0)
+    {
+      minval = base;
+      for (n = 0; n < rank; n++)
+        dest[n * dstride] = count[n] + 1;
+    }')
+
+MASKED_FOREACH_FUNCTION(
+`  const atype_name *minval;
+
+  minval = NULL;'
+,
+`  if (*mbase && (minval == NULL || compare_fcn (base, minval, len) < 0))
+    {
+      minval = base;
+      for (n = 0; n < rank; n++)
+        dest[n * dstride] = count[n] + 1;
+    }')
+
+SCALAR_FOREACH_FUNCTION(`0')
+#endif
diff --git a/libgfortran/m4/minloc1s.m4 b/libgfortran/m4/minloc1s.m4
new file mode 100644
index 00000000000..d64935a36ad
--- /dev/null
+++ b/libgfortran/m4/minloc1s.m4
@@ -0,0 +1,65 @@
+`/* 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(iparm.m4)dnl
+include(ifunction-s.m4)dnl
+
+`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)'
+
+ARRAY_FUNCTION(0,
+`	const atype_name *minval;
+	minval = base;
+	result = 1;',
+`		if (compare_fcn (src, minval, string_len) < 0)
+		  {
+		    minval = src;
+		    result = (rtype_name)n + 1;
+		  }', `')
+
+MASKED_ARRAY_FUNCTION(0,
+`	const atype_name *minval;
+	minval = base;
+	result = 0;',
+`		if (*msrc)
+		      {
+			minval = src;
+			result = (rtype_name)n + 1;
+			break;
+		      }
+            }
+	    for (; n < len; n++, src += delta, msrc += mdelta)
+	      {
+		if (*msrc && compare_fcn (src, minval, string_len) < 0)
+		  {
+		    minval = src;
+		    result = (rtype_name)n + 1;
+		  }
+	      ')
+
+SCALAR_ARRAY_FUNCTION(0)
+
+#endif
diff --git a/libgfortran/m4/minloc2s.m4 b/libgfortran/m4/minloc2s.m4
new file mode 100644
index 00000000000..38073ce75d5
--- /dev/null
+++ b/libgfortran/m4/minloc2s.m4
@@ -0,0 +1,156 @@
+`/* 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(iparm.m4)dnl
+
+`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)
+
+static inline int
+compare_fcn (const 'atype_name` *a, const 'atype_name` *b, int n)
+{
+  if (sizeof ('atype_name`) == 1)
+    return memcmp (a, b, n);
+  else
+    return memcmp_char4 (a, b, n);
+}
+
+extern 'rtype_name` 'name`'rtype_qual`_'atype_code` ('atype` * const restrict, int);
+export_proto('name`'rtype_qual`_'atype_code`);
+
+'rtype_name`
+'name`'rtype_qual`_'atype_code` ('atype` * const restrict array, gfc_charlen_type len)
+{
+  index_type ret;
+  index_type sstride;
+  index_type extent;
+  const 'atype_name` *src;
+  const 'atype_name` *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 'rtype_name` m'name`'rtype_qual`_'atype_code` ('atype` * const restrict,
+       		    	gfc_array_l1 *const restrict mask, int);
+export_proto(m'name`'rtype_qual`_'atype_code`);
+
+'rtype_name`
+m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
+				 gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+{
+  index_type ret;
+  index_type sstride;
+  index_type extent;
+  const 'atype_name` *src;
+  const 'atype_name` *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 'rtype_name` s'name`'rtype_qual`_'atype_code` ('atype` * const restrict,
+       		    	GFC_LOGICAL_4 *mask, gfc_charlen_type);
+export_proto(s'name`'rtype_qual`_'atype_code`);
+
+'rtype_name`
+s'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
+				 GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+{
+  if (mask)
+    return 'name`'rtype_qual`_'atype_code` (array, len);
+  else
+    return 0;
+}
+
+#endif'