[thirdparty/gcc.git] / libgfortran / generated / maxval1_s4.c

/* Implementation of the MAXVAL intrinsic
   Copyright (C) 2017-2023 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_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4)

#include <string.h>
#include <assert.h>

static inline int
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
{
  if (sizeof (GFC_UINTEGER_4) == 1)
    return memcmp (a, b, n);
  else
    return memcmp_char4 (a, b, n);
}

extern void maxval1_s4 (gfc_array_s4 * const restrict,
        gfc_charlen_type, gfc_array_s4 * const restrict,
	const index_type * const restrict, gfc_charlen_type);
export_proto(maxval1_s4);

void
maxval1_s4 (gfc_array_s4 * const restrict retarray, 
	gfc_charlen_type xlen, 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_UINTEGER_4 * restrict base;
  GFC_UINTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

  assert (xlen == string_len);
  /* 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 MAXVAL 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.rank = rank;

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
      		 * string_len;

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_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"
		       " MAXVAL 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", "MAXVAL");
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
      if (extent[n] <= 0)
	return;
    }

  base = array->base_addr;
  dest = retarray->base_addr;

  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_UINTEGER_4 * restrict src;
      src = base;
      {

	const GFC_UINTEGER_4 *retval;
	retval = base;
	if (len <= 0)
	  memset (dest, 0, sizeof (*dest) * string_len);
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

		if (compare_fcn (src, retval, string_len) > 0)
		  {
		    retval = src;
		  }
	      }
	    
	    memcpy (dest, retval, sizeof (*dest) * string_len);
	  }
      }
      /* 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 mmaxval1_s4 (gfc_array_s4 * const restrict,
        gfc_charlen_type, gfc_array_s4 * const restrict,
	const index_type * const restrict,
	gfc_array_l1 * const restrict, gfc_charlen_type);
export_proto(mmaxval1_s4);

void
mmaxval1_s4 (gfc_array_s4 * const restrict retarray, 
	gfc_charlen_type xlen, 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_UINTEGER_4 * restrict dest;
  const GFC_UINTEGER_4 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

  if (mask == NULL)
    {
      maxval1_s4 (retarray, xlen, array, pdim, string_len);
      return;
    }

  assert (xlen == string_len);

  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in MAXVAL 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]
      		 * string_len;

      retarray->offset = 0;
      retarray->dtype.rank = 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_UINTEGER_4));

    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in MAXVAL intrinsic");

      if (unlikely (compile_options.bounds_check))
	{
	  bounds_ifunction_return ((array_t *) retarray, extent,
				   "return value", "MAXVAL");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
	  			"MASK argument", "MAXVAL");
	}
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
      if (extent[n] <= 0)
	return;
    }

  dest = retarray->base_addr;
  base = array->base_addr;

  while (base)
    {
      const GFC_UINTEGER_4 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;

      src = base;
      msrc = mbase;
      {

	const GFC_UINTEGER_4 *retval;
	memset (dest, 0, sizeof (*dest) * string_len);
	retval = dest;
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

		if (*msrc)
		      {
			retval = src;
			break;
		      }
	    }
	    for (; n < len; n++, src += delta, msrc += mdelta)
	      {
		if (*msrc && compare_fcn (src, retval, string_len) > 0)
		  {
		    retval = src;
		  }
	      
	  }
	memcpy (dest, retval, sizeof (*dest) * string_len);
      }
      /* 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];
	    }
	}
    }
}


void smaxval1_s4 (gfc_array_s4 * const restrict,
        gfc_charlen_type, gfc_array_s4 * const restrict,
	const index_type * const restrict,
	GFC_LOGICAL_4 *, gfc_charlen_type);

export_proto(smaxval1_s4);

void
smaxval1_s4 (gfc_array_s4 * const restrict retarray, 
	gfc_charlen_type xlen, 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_UINTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
      maxval1_s4 (retarray, xlen, 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 MAXVAL intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  for (n = 0; n < dim; n++)
    {
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  for (n = dim; n < rank; n++)
    {
      extent[n] =
	GFC_DESCRIPTOR_EXTENT(array,n + 1);

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      retarray->offset = 0;
      retarray->dtype.rank = rank;

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
      		 * string_len;

      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_UINTEGER_4));
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " MAXVAL 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"
			       " MAXVAL 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) * string_len;
    }

  dest = retarray->base_addr;

  while(1)
    {
      memset (dest, 0, sizeof (*dest) * string_len);
      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
Commit	Line	Data
0ac74254	1	/* Implementation of the MAXVAL intrinsic
83ffe9cd	2	Copyright (C) 2017-2023 Free Software Foundation, Inc.
0ac74254 TK	3	Contributed by Thomas Koenig
	4
	5	This file is part of the GNU Fortran runtime library (libgfortran).
	6
	7	Libgfortran is free software; you can redistribute it and/or
	8	modify it under the terms of the GNU General Public
	9	License as published by the Free Software Foundation; either
	10	version 3 of the License, or (at your option) any later version.
	11
	12	Libgfortran is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
	16
	17	Under Section 7 of GPL version 3, you are granted additional
	18	permissions described in the GCC Runtime Library Exception, version
	19	3.1, as published by the Free Software Foundation.
	20
	21	You should have received a copy of the GNU General Public License and
	22	a copy of the GCC Runtime Library Exception along with this program;
	23	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	24	<http://www.gnu.org/licenses/>. */
	25
	26	#include "libgfortran.h"
	27
	28
01ce9e31	29	#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_UINTEGER_4)
0ac74254 TK	30
	31	#include <string.h>
	32	#include <assert.h>
	33
	34	static inline int
01ce9e31	35	compare_fcn (const GFC_UINTEGER_4 a, const GFC_UINTEGER_4 b, gfc_charlen_type n)
0ac74254	36	{
01ce9e31	37	if (sizeof (GFC_UINTEGER_4) == 1)
0ac74254 TK	38	return memcmp (a, b, n);
	39	else
	40	return memcmp_char4 (a, b, n);
	41	}
	42
	43	extern void maxval1_s4 (gfc_array_s4 * const restrict,
	44	gfc_charlen_type, gfc_array_s4 * const restrict,
	45	const index_type * const restrict, gfc_charlen_type);
	46	export_proto(maxval1_s4);
	47
	48	void
	49	maxval1_s4 (gfc_array_s4 * const restrict retarray,
	50	gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
	51	const index_type * const restrict pdim, gfc_charlen_type string_len)
	52	{
	53	index_type count[GFC_MAX_DIMENSIONS];
	54	index_type extent[GFC_MAX_DIMENSIONS];
	55	index_type sstride[GFC_MAX_DIMENSIONS];
	56	index_type dstride[GFC_MAX_DIMENSIONS];
01ce9e31 TK	57	const GFC_UINTEGER_4 * restrict base;
01ce9e31 TK	58	GFC_UINTEGER_4 * restrict dest;
0ac74254 TK	59	index_type rank;
	60	index_type n;
	61	index_type len;
	62	index_type delta;
	63	index_type dim;
	64	int continue_loop;
	65
	66	assert (xlen == string_len);
	67	/* Make dim zero based to avoid confusion. */
	68	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	69	dim = (*pdim) - 1;
	70
	71	if (unlikely (dim < 0 \|\| dim > rank))
	72	{
	73	runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
	74	"is %ld, should be between 1 and %ld",
	75	(long int) dim + 1, (long int) rank + 1);
	76	}
	77
	78	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	79	if (len < 0)
	80	len = 0;
	81
	82	delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
	83
	84	for (n = 0; n < dim; n++)
	85	{
	86	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
	87	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	88
	89	if (extent[n] < 0)
	90	extent[n] = 0;
	91	}
	92	for (n = dim; n < rank; n++)
	93	{
	94	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
	95	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	96
	97	if (extent[n] < 0)
	98	extent[n] = 0;
	99	}
	100
	101	if (retarray->base_addr == NULL)
	102	{
	103	size_t alloc_size, str;
	104
	105	for (n = 0; n < rank; n++)
	106	{
	107	if (n == 0)
	108	str = 1;
	109	else
	110	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	111
	112	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	113
	114	}
	115
	116	retarray->offset = 0;
ca708a2b	117	retarray->dtype.rank = rank;
0ac74254 TK	118
	119	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
	120	* string_len;
	121
01ce9e31	122	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4));
0ac74254 TK	123	if (alloc_size == 0)
	124	{
	125	/* Make sure we have a zero-sized array. */
	126	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	127	return;
	128
	129	}
	130	}
	131	else
	132	{
	133	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	134	runtime_error ("rank of return array incorrect in"
	135	" MAXVAL intrinsic: is %ld, should be %ld",
	136	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	137	(long int) rank);
	138
	139	if (unlikely (compile_options.bounds_check))
	140	bounds_ifunction_return ((array_t *) retarray, extent,
	141	"return value", "MAXVAL");
	142	}
	143
	144	for (n = 0; n < rank; n++)
	145	{
	146	count[n] = 0;
	147	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
	148	if (extent[n] <= 0)
	149	return;
	150	}
	151
	152	base = array->base_addr;
	153	dest = retarray->base_addr;
	154
	155	continue_loop = 1;
	156	while (continue_loop)
	157	{
01ce9e31	158	const GFC_UINTEGER_4 * restrict src;
0ac74254 TK	159	src = base;
	160	{
	161
01ce9e31	162	const GFC_UINTEGER_4 *retval;
0ac74254 TK	163	retval = base;
	164	if (len <= 0)
	165	memset (dest, 0, sizeof (dest) string_len);
	166	else
	167	{
	168	for (n = 0; n < len; n++, src += delta)
	169	{
	170
	171	if (compare_fcn (src, retval, string_len) > 0)
	172	{
	173	retval = src;
	174	}
	175	}
	176
	177	memcpy (dest, retval, sizeof (dest) string_len);
	178	}
	179	}
	180	/* Advance to the next element. */
	181	count[0]++;
	182	base += sstride[0];
	183	dest += dstride[0];
	184	n = 0;
	185	while (count[n] == extent[n])
	186	{
	187	/* When we get to the end of a dimension, reset it and increment
	188	the next dimension. */
	189	count[n] = 0;
	190	/* We could precalculate these products, but this is a less
	191	frequently used path so probably not worth it. */
	192	base -= sstride[n] * extent[n];
	193	dest -= dstride[n] * extent[n];
	194	n++;
	195	if (n >= rank)
	196	{
	197	/* Break out of the loop. */
	198	continue_loop = 0;
	199	break;
	200	}
	201	else
	202	{
	203	count[n]++;
	204	base += sstride[n];
	205	dest += dstride[n];
	206	}
	207	}
	208	}
	209	}
	210
	211
	212	extern void mmaxval1_s4 (gfc_array_s4 * const restrict,
	213	gfc_charlen_type, gfc_array_s4 * const restrict,
	214	const index_type * const restrict,
	215	gfc_array_l1 * const restrict, gfc_charlen_type);
	216	export_proto(mmaxval1_s4);
	217
	218	void
	219	mmaxval1_s4 (gfc_array_s4 * const restrict retarray,
	220	gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
	221	const index_type * const restrict pdim,
	222	gfc_array_l1 * const restrict mask,
	223	gfc_charlen_type string_len)
	224
	225	{
	226	index_type count[GFC_MAX_DIMENSIONS];
227	index_type extent[GFC_MAX_DIMENSIONS];
228	index_type sstride[GFC_MAX_DIMENSIONS];
229	index_type dstride[GFC_MAX_DIMENSIONS];
230	index_type mstride[GFC_MAX_DIMENSIONS];
01ce9e31 TK	231	GFC_UINTEGER_4 * restrict dest;
01ce9e31 TK	232	const GFC_UINTEGER_4 * restrict base;
0ac74254 TK	233	const GFC_LOGICAL_1 * restrict mbase;
	234	index_type rank;
	235	index_type dim;
	236	index_type n;
	237	index_type len;
	238	index_type delta;
	239	index_type mdelta;
	240	int mask_kind;
	241
2ea47ee9 TK	242	if (mask == NULL)
	243	{
	244	maxval1_s4 (retarray, xlen, array, pdim, string_len);
	245	return;
	246	}
	247
0ac74254 TK	248	assert (xlen == string_len);
	249
	250	dim = (*pdim) - 1;
	251	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	252
	253	if (unlikely (dim < 0 \|\| dim > rank))
	254	{
	255	runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
	256	"is %ld, should be between 1 and %ld",
	257	(long int) dim + 1, (long int) rank + 1);
	258	}
	259
	260	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	261	if (len <= 0)
	262	return;
	263
	264	mbase = mask->base_addr;
	265
	266	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	267
	268	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	269	#ifdef HAVE_GFC_LOGICAL_16
	270	\|\| mask_kind == 16
	271	#endif
	272	)
	273	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	274	else
	275	runtime_error ("Funny sized logical array");
	276
	277	delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
	278	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	279
	280	for (n = 0; n < dim; n++)
	281	{
	282	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
	283	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	284	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	285
	286	if (extent[n] < 0)
	287	extent[n] = 0;
	288
	289	}
	290	for (n = dim; n < rank; n++)
	291	{
	292	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
	293	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	294	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	295
	296	if (extent[n] < 0)
	297	extent[n] = 0;
	298	}
	299
	300	if (retarray->base_addr == NULL)
	301	{
	302	size_t alloc_size, str;
	303
	304	for (n = 0; n < rank; n++)
	305	{
	306	if (n == 0)
	307	str = 1;
	308	else
	309	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	310
	311	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
312
313	}
314
315	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
316	* string_len;
317
318	retarray->offset = 0;
ca708a2b	319	retarray->dtype.rank = rank;
0ac74254 TK	320
	321	if (alloc_size == 0)
	322	{
	323	/* Make sure we have a zero-sized array. */
	324	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	325	return;
	326	}
	327	else
01ce9e31	328	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4));
0ac74254 TK	329
	330	}
	331	else
	332	{
	333	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	334	runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
	335
	336	if (unlikely (compile_options.bounds_check))
	337	{
	338	bounds_ifunction_return ((array_t *) retarray, extent,
	339	"return value", "MAXVAL");
	340	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	341	"MASK argument", "MAXVAL");
	342	}
	343	}
	344
	345	for (n = 0; n < rank; n++)
	346	{
	347	count[n] = 0;
	348	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
	349	if (extent[n] <= 0)
	350	return;
	351	}
	352
	353	dest = retarray->base_addr;
	354	base = array->base_addr;
	355
	356	while (base)
	357	{
01ce9e31	358	const GFC_UINTEGER_4 * restrict src;
0ac74254 TK	359	const GFC_LOGICAL_1 * restrict msrc;
	360
	361	src = base;
	362	msrc = mbase;
	363	{
	364
01ce9e31	365	const GFC_UINTEGER_4 *retval;
0ac74254 TK	366	memset (dest, 0, sizeof (dest) string_len);
	367	retval = dest;
	368	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	369	{
	370
	371	if (*msrc)
	372	{
	373	retval = src;
	374	break;
	375	}
	376	}
	377	for (; n < len; n++, src += delta, msrc += mdelta)
	378	{
	379	if (*msrc && compare_fcn (src, retval, string_len) > 0)
	380	{
	381	retval = src;
	382	}
	383
	384	}
	385	memcpy (dest, retval, sizeof (dest) string_len);
	386	}
	387	/* Advance to the next element. */
	388	count[0]++;
	389	base += sstride[0];
	390	mbase += mstride[0];
	391	dest += dstride[0];
	392	n = 0;
	393	while (count[n] == extent[n])
	394	{
	395	/* When we get to the end of a dimension, reset it and increment
	396	the next dimension. */
	397	count[n] = 0;
	398	/* We could precalculate these products, but this is a less
	399	frequently used path so probably not worth it. */
	400	base -= sstride[n] * extent[n];
	401	mbase -= mstride[n] * extent[n];
	402	dest -= dstride[n] * extent[n];
	403	n++;
	404	if (n >= rank)
	405	{
	406	/* Break out of the loop. */
	407	base = NULL;
	408	break;
	409	}
	410	else
	411	{
	412	count[n]++;
	413	base += sstride[n];
	414	mbase += mstride[n];
	415	dest += dstride[n];
	416	}
	417	}
	418	}
	419	}
	420
	421
	422	void smaxval1_s4 (gfc_array_s4 * const restrict,
	423	gfc_charlen_type, gfc_array_s4 * const restrict,
	424	const index_type * const restrict,
	425	GFC_LOGICAL_4 *, gfc_charlen_type);
	426
	427	export_proto(smaxval1_s4);
	428
	429	void
430	smaxval1_s4 (gfc_array_s4 * const restrict retarray,
431	gfc_charlen_type xlen, gfc_array_s4 * const restrict array,
432	const index_type * const restrict pdim,
433	GFC_LOGICAL_4 *mask, gfc_charlen_type string_len)
434
435	{
436	index_type count[GFC_MAX_DIMENSIONS];
437	index_type extent[GFC_MAX_DIMENSIONS];
438	index_type dstride[GFC_MAX_DIMENSIONS];
01ce9e31	439	GFC_UINTEGER_4 * restrict dest;
0ac74254 TK	440	index_type rank;
	441	index_type n;
	442	index_type dim;
	443
	444
2ea47ee9	445	if (mask == NULL \|\| *mask)
0ac74254 TK	446	{
	447	maxval1_s4 (retarray, xlen, array, pdim, string_len);
	448	return;
	449	}
	450	/* Make dim zero based to avoid confusion. */
	451	dim = (*pdim) - 1;
	452	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	453
	454	if (unlikely (dim < 0 \|\| dim > rank))
	455	{
	456	runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
	457	"is %ld, should be between 1 and %ld",
	458	(long int) dim + 1, (long int) rank + 1);
	459	}
	460
	461	for (n = 0; n < dim; n++)
	462	{
	463	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	464
	465	if (extent[n] <= 0)
	466	extent[n] = 0;
	467	}
	468
	469	for (n = dim; n < rank; n++)
	470	{
	471	extent[n] =
	472	GFC_DESCRIPTOR_EXTENT(array,n + 1);
	473
	474	if (extent[n] <= 0)
	475	extent[n] = 0;
	476	}
	477
	478	if (retarray->base_addr == NULL)
	479	{
	480	size_t alloc_size, str;
	481
	482	for (n = 0; n < rank; n++)
	483	{
	484	if (n == 0)
	485	str = 1;
	486	else
	487	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	488
	489	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	490
	491	}
	492
	493	retarray->offset = 0;
ca708a2b	494	retarray->dtype.rank = rank;
0ac74254 TK	495
	496	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]
	497	* string_len;
	498
	499	if (alloc_size == 0)
	500	{
	501	/* Make sure we have a zero-sized array. */
	502	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	503	return;
	504	}
	505	else
01ce9e31	506	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_UINTEGER_4));
0ac74254 TK	507	}
	508	else
	509	{
	510	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	511	runtime_error ("rank of return array incorrect in"
	512	" MAXVAL intrinsic: is %ld, should be %ld",
	513	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	514	(long int) rank);
	515
	516	if (unlikely (compile_options.bounds_check))
	517	{
	518	for (n=0; n < rank; n++)
	519	{
	520	index_type ret_extent;
	521
	522	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	523	if (extent[n] != ret_extent)
	524	runtime_error ("Incorrect extent in return value of"
	525	" MAXVAL intrinsic in dimension %ld:"
	526	" is %ld, should be %ld", (long int) n + 1,
	527	(long int) ret_extent, (long int) extent[n]);
	528	}
	529	}
	530	}
	531
	532	for (n = 0; n < rank; n++)
	533	{
	534	count[n] = 0;
	535	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len;
	536	}
	537
	538	dest = retarray->base_addr;
	539
	540	while(1)
	541	{
	542	memset (dest, 0, sizeof (dest) string_len);
	543	count[0]++;
	544	dest += dstride[0];
	545	n = 0;
	546	while (count[n] == extent[n])
	547	{
	548	/* When we get to the end of a dimension, reset it and increment
	549	the next dimension. */
	550	count[n] = 0;
	551	/* We could precalculate these products, but this is a less
	552	frequently used path so probably not worth it. */
	553	dest -= dstride[n] * extent[n];
	554	n++;
	555	if (n >= rank)
	556	return;
	557	else
	558	{
	559	count[n]++;
	560	dest += dstride[n];
	561	}
	562	}
	563	}
	564	}
	565
	566	#endif