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

/* Implementation of the MAXVAL intrinsic
   Copyright (C) 2002-2019 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

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_2) && defined (HAVE_GFC_INTEGER_2)


extern void maxval_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict);
export_proto(maxval_i2);

void
maxval_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * const restrict array, 
	const index_type * const restrict pdim)
{
  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_2 * restrict base;
  GFC_INTEGER_2 * 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 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);

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

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

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

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

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

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

	}

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

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

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_2));
      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);
      if (extent[n] <= 0)
	return;
    }

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

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

#if defined (GFC_INTEGER_2_INFINITY)
	result = -GFC_INTEGER_2_INFINITY;
#else
	result = (-GFC_INTEGER_2_HUGE-1);
#endif
	if (len <= 0)
	  *dest = (-GFC_INTEGER_2_HUGE-1);
	else
	  {
#if ! defined HAVE_BACK_ARG
	    for (n = 0; n < len; n++, src += delta)
	      {
#endif

#if defined (GFC_INTEGER_2_QUIET_NAN)
		if (*src >= result)
		  break;
	      }
	    if (unlikely (n >= len))
	      result = GFC_INTEGER_2_QUIET_NAN;
	    else for (; n < len; n++, src += delta)
	      {
#endif
		if (*src > result)
		  result = *src;
	      }
	    
	    *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 mmaxval_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxval_i2);

void
mmaxval_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask)
{
  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_2 * restrict dest;
  const GFC_INTEGER_2 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

  if (mask == NULL)
    {
#ifdef HAVE_BACK_ARG
      maxval_i2 (retarray, array, pdim, back);
#else
      maxval_i2 (retarray, array, pdim);
#endif
      return;
    }

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


  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in 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);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

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

    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

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

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

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

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

	}

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

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

      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_2));

    }
  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);
      if (extent[n] <= 0)
	return;
    }

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

  while (base)
    {
      const GFC_INTEGER_2 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_2 result;
      src = base;
      msrc = mbase;
      {

#if defined (GFC_INTEGER_2_INFINITY)
	result = -GFC_INTEGER_2_INFINITY;
#else
	result = (-GFC_INTEGER_2_HUGE-1);
#endif
#if defined (GFC_INTEGER_2_QUIET_NAN)
	int non_empty_p = 0;
#endif
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

#if defined (GFC_INTEGER_2_INFINITY) || defined (GFC_INTEGER_2_QUIET_NAN)
		if (*msrc)
		  {
#if defined (GFC_INTEGER_2_QUIET_NAN)
		    non_empty_p = 1;
		    if (*src >= result)
#endif
		      break;
		  }
	      }
	    if (unlikely (n >= len))
	      {
#if defined (GFC_INTEGER_2_QUIET_NAN)
		result = non_empty_p ? GFC_INTEGER_2_QUIET_NAN : (-GFC_INTEGER_2_HUGE-1);
#else
		result = (-GFC_INTEGER_2_HUGE-1);
#endif
	      }
	    else for (; n < len; n++, src += delta, msrc += mdelta)
	      {
#endif
		if (*msrc && *src > result)
		  result = *src;
	  }
	*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 smaxval_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxval_i2);

void
smaxval_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_2 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      maxval_i2 (retarray, array, pdim, back);
#else
      maxval_i2 (retarray, array, pdim);
#endif
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

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

      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_2));
    }
  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);
    }

  dest = retarray->base_addr;

  while(1)
    {
      *dest = (-GFC_INTEGER_2_HUGE-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];
	    }
      	}
    }
}

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