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

/* Implementation of the MAXVAL intrinsic
   Copyright (C) 2002-2024 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_16) && defined (HAVE_GFC_INTEGER_16)


extern void maxval_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict);
export_proto(maxval_i16);

void
maxval_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_16 * restrict base;
  GFC_INTEGER_16 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

  /* Make dim zero based to avoid confusion.  */
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
  dim = (*pdim) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in 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_16));
      if (alloc_size == 0)
	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_16 * restrict src;
      GFC_INTEGER_16 result;
      src = base;
      {

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

#if defined (GFC_INTEGER_16_QUIET_NAN)
		if (*src >= result)
		  break;
	      }
	    if (unlikely (n >= len))
	      result = GFC_INTEGER_16_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_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxval_i16);

void
mmaxval_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_16 * restrict dest;
  const GFC_INTEGER_16 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

  if (mask == NULL)
    {
#ifdef HAVE_BACK_ARG
      maxval_i16 (retarray, array, pdim, back);
#else
      maxval_i16 (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)
    len = 0;

  mbase = mask->base_addr;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
  else
    runtime_error ("Funny sized logical array");

  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

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

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

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

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

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

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

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

	}

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

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

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
      if (alloc_size == 0)
	return;
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in 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_16 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_16 result;
      src = base;
      msrc = mbase;
      {

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

#if defined (GFC_INTEGER_16_INFINITY) || defined (GFC_INTEGER_16_QUIET_NAN)
		if (*msrc)
		  {
#if defined (GFC_INTEGER_16_QUIET_NAN)
		    non_empty_p = 1;
		    if (*src >= result)
#endif
		      break;
		  }
	      }
	    if (unlikely (n >= len))
	      {
#if defined (GFC_INTEGER_16_QUIET_NAN)
		result = non_empty_p ? GFC_INTEGER_16_QUIET_NAN : (-GFC_INTEGER_16_HUGE-1);
#else
		result = (-GFC_INTEGER_16_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_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxval_i16);

void
smaxval_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_16 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      maxval_i16 (retarray, array, pdim, back);
#else
      maxval_i16 (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];

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