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

/* Implementation of the MAXVAL intrinsic
   Copyright (C) 2002-2018 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_1) && defined (HAVE_GFC_INTEGER_1)


extern void maxval_i1 (gfc_array_i1 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict);
export_proto(maxval_i1);

void
maxval_i1 (gfc_array_i1 * const restrict retarray, 
	gfc_array_i1 * 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_1 * restrict base;
  GFC_INTEGER_1 * 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

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

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
      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_1 * restrict src;
      GFC_INTEGER_1 result;
      src = base;
      {

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

#if defined (GFC_INTEGER_1_QUIET_NAN)
		if (*src >= result)
		  break;
	      }
	    if (unlikely (n >= len))
	      result = GFC_INTEGER_1_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_i1 (gfc_array_i1 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxval_i1);

void
mmaxval_i1 (gfc_array_i1 * const restrict retarray, 
	gfc_array_i1 * 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_1 * restrict dest;
  const GFC_INTEGER_1 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

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


  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));

    }
  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_1 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_1 result;
      src = base;
      msrc = mbase;
      {

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

#if defined (GFC_INTEGER_1_INFINITY) || defined (GFC_INTEGER_1_QUIET_NAN)
		if (*msrc)
		  {
#if defined (GFC_INTEGER_1_QUIET_NAN)
		    non_empty_p = 1;
		    if (*src >= result)
#endif
		      break;
		  }
	      }
	    if (unlikely (n >= len))
	      {
#if defined (GFC_INTEGER_1_QUIET_NAN)
		result = non_empty_p ? GFC_INTEGER_1_QUIET_NAN : (-GFC_INTEGER_1_HUGE-1);
#else
		result = (-GFC_INTEGER_1_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_i1 (gfc_array_i1 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxval_i1);

void
smaxval_i1 (gfc_array_i1 * const restrict retarray, 
	gfc_array_i1 * 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_1 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      maxval_i1 (retarray, array, pdim);
      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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

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

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
    }
  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_1_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
567c915b	1	/* Implementation of the MAXVAL intrinsic
85ec4feb	2	Copyright (C) 2002-2018 Free Software Foundation, Inc.
567c915b TK	3	Contributed by Paul Brook <paul@nowt.org>
567c915b TK	4
0cd0559e	5	This file is part of the GNU Fortran runtime library (libgfortran).
567c915b TK	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.
567c915b TK	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/>. */
567c915b	25
36ae8a61	26	#include "libgfortran.h"
567c915b TK	27
	28
	29	#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)
	30
	31
	32	extern void maxval_i1 (gfc_array_i1 * const restrict,
	33	gfc_array_i1 * const restrict, const index_type * const restrict);
	34	export_proto(maxval_i1);
	35
	36	void
	37	maxval_i1 (gfc_array_i1 * const restrict retarray,
	38	gfc_array_i1 * 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_1 * restrict base;
	46	GFC_INTEGER_1 * restrict dest;
	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;
567c915b TK	53
567c915b TK	54	/* Make dim zero based to avoid confusion. */
567c915b	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	}
567c915b	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);
567c915b TK	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);
567c915b TK	74
	75	if (extent[n] < 0)
	76	extent[n] = 0;
	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);
567c915b TK	82
	83	if (extent[n] < 0)
	84	extent[n] = 0;
	85	}
	86
21d1335b	87	if (retarray->base_addr == NULL)
567c915b	88	{
dfb55fdc	89	size_t alloc_size, str;
567c915b TK	90
567c915b TK	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	}
567c915b TK	101
	102	retarray->offset = 0;
	103	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	104
92e6f3a4	105	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
567c915b	106
92e6f3a4	107	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
567c915b TK	108	if (alloc_size == 0)
	109	{
	110	/* Make sure we have a zero-sized array. */
dfb55fdc	111	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
567c915b	112	return;
dfb55fdc	113
567c915b	114	}
567c915b TK	115	}
	116	else
	117	{
	118	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8	119	runtime_error ("rank of return array incorrect in"
ccacefc7 TK	120	" MAXVAL intrinsic: is %ld, should be %ld",
	121	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	122	(long int) rank);
fd6590f8	123
9731c4a3	124	if (unlikely (compile_options.bounds_check))
16bff921 TK	125	bounds_ifunction_return ((array_t *) retarray, extent,
16bff921 TK	126	"return value", "MAXVAL");
567c915b TK	127	}
	128
	129	for (n = 0; n < rank; n++)
	130	{
	131	count[n] = 0;
dfb55fdc	132	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
567c915b	133	if (extent[n] <= 0)
facc1285	134	return;
567c915b TK	135	}
567c915b TK	136
21d1335b TB	137	base = array->base_addr;
21d1335b TB	138	dest = retarray->base_addr;
567c915b	139
da96f5ab TK	140	continue_loop = 1;
da96f5ab TK	141	while (continue_loop)
567c915b TK	142	{
	143	const GFC_INTEGER_1 * restrict src;
	144	GFC_INTEGER_1 result;
	145	src = base;
	146	{
	147
80927a56 JJ	148	#if defined (GFC_INTEGER_1_INFINITY)
	149	result = -GFC_INTEGER_1_INFINITY;
	150	#else
	151	result = (-GFC_INTEGER_1_HUGE-1);
	152	#endif
	153	if (len <= 0)
567c915b TK	154	*dest = (-GFC_INTEGER_1_HUGE-1);
	155	else
	156	{
	157	for (n = 0; n < len; n++, src += delta)
	158	{
	159
80927a56 JJ	160	#if defined (GFC_INTEGER_1_QUIET_NAN)
	161	if (*src >= result)
	162	break;
	163	}
	164	if (unlikely (n >= len))
	165	result = GFC_INTEGER_1_QUIET_NAN;
	166	else for (; n < len; n++, src += delta)
	167	{
	168	#endif
	169	if (*src > result)
	170	result = *src;
	171	}
0cd0559e	172
567c915b TK	173	*dest = result;
	174	}
	175	}
	176	/* Advance to the next element. */
	177	count[0]++;
	178	base += sstride[0];
	179	dest += dstride[0];
	180	n = 0;
	181	while (count[n] == extent[n])
80927a56 JJ	182	{
	183	/* When we get to the end of a dimension, reset it and increment
	184	the next dimension. */
	185	count[n] = 0;
	186	/* We could precalculate these products, but this is a less
	187	frequently used path so probably not worth it. */
	188	base -= sstride[n] * extent[n];
	189	dest -= dstride[n] * extent[n];
	190	n++;
80dd631f	191	if (n >= rank)
80927a56	192	{
80dd631f	193	/* Break out of the loop. */
da96f5ab TK	194	continue_loop = 0;
da96f5ab TK	195	break;
80927a56 JJ	196	}
	197	else
	198	{
	199	count[n]++;
	200	base += sstride[n];
	201	dest += dstride[n];
	202	}
	203	}
567c915b TK	204	}
	205	}
	206
	207
	208	extern void mmaxval_i1 (gfc_array_i1 * const restrict,
	209	gfc_array_i1 * const restrict, const index_type * const restrict,
28dc6b33	210	gfc_array_l1 * const restrict);
567c915b TK	211	export_proto(mmaxval_i1);
	212
	213	void
	214	mmaxval_i1 (gfc_array_i1 * const restrict retarray,
	215	gfc_array_i1 * const restrict array,
	216	const index_type * const restrict pdim,
28dc6b33	217	gfc_array_l1 * const restrict mask)
567c915b TK	218	{
	219	index_type count[GFC_MAX_DIMENSIONS];
	220	index_type extent[GFC_MAX_DIMENSIONS];
	221	index_type sstride[GFC_MAX_DIMENSIONS];
	222	index_type dstride[GFC_MAX_DIMENSIONS];
	223	index_type mstride[GFC_MAX_DIMENSIONS];
	224	GFC_INTEGER_1 * restrict dest;
	225	const GFC_INTEGER_1 * restrict base;
28dc6b33	226	const GFC_LOGICAL_1 * restrict mbase;
cfdf6ff6 TK	227	index_type rank;
cfdf6ff6 TK	228	index_type dim;
567c915b TK	229	index_type n;
	230	index_type len;
	231	index_type delta;
	232	index_type mdelta;
28dc6b33	233	int mask_kind;
567c915b TK	234
	235	dim = (*pdim) - 1;
	236	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	237
cfdf6ff6 TK	238
	239	if (unlikely (dim < 0 \|\| dim > rank))
	240	{
	241	runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
	242	"is %ld, should be between 1 and %ld",
	243	(long int) dim + 1, (long int) rank + 1);
	244	}
	245
dfb55fdc	246	len = GFC_DESCRIPTOR_EXTENT(array,dim);
567c915b TK	247	if (len <= 0)
567c915b TK	248	return;
28dc6b33	249
21d1335b	250	mbase = mask->base_addr;
28dc6b33 TK	251
	252	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	253
	254	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	255	#ifdef HAVE_GFC_LOGICAL_16
	256	\|\| mask_kind == 16
	257	#endif
	258	)
	259	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	260	else
	261	runtime_error ("Funny sized logical array");
	262
dfb55fdc TK	263	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
dfb55fdc TK	264	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
567c915b TK	265
	266	for (n = 0; n < dim; n++)
	267	{
dfb55fdc TK	268	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	269	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	270	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
567c915b TK	271
	272	if (extent[n] < 0)
	273	extent[n] = 0;
	274
	275	}
	276	for (n = dim; n < rank; n++)
	277	{
dfb55fdc TK	278	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
	279	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	280	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
567c915b TK	281
	282	if (extent[n] < 0)
	283	extent[n] = 0;
	284	}
	285
21d1335b	286	if (retarray->base_addr == NULL)
567c915b	287	{
dfb55fdc	288	size_t alloc_size, str;
567c915b TK	289
567c915b TK	290	for (n = 0; n < rank; n++)
80927a56 JJ	291	{
	292	if (n == 0)
	293	str = 1;
	294	else
	295	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	296
	297	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	298
80927a56	299	}
567c915b	300
92e6f3a4	301	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
567c915b TK	302
	303	retarray->offset = 0;
	304	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	305
	306	if (alloc_size == 0)
	307	{
	308	/* Make sure we have a zero-sized array. */
dfb55fdc	309	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
567c915b TK	310	return;
	311	}
	312	else
92e6f3a4	313	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
567c915b TK	314
	315	}
	316	else
	317	{
	318	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8 TK	319	runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
fd6590f8 TK	320
9731c4a3	321	if (unlikely (compile_options.bounds_check))
fd6590f8	322	{
16bff921 TK	323	bounds_ifunction_return ((array_t *) retarray, extent,
	324	"return value", "MAXVAL");
	325	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	326	"MASK argument", "MAXVAL");
fd6590f8	327	}
567c915b TK	328	}
	329
	330	for (n = 0; n < rank; n++)
	331	{
	332	count[n] = 0;
dfb55fdc	333	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
567c915b	334	if (extent[n] <= 0)
80927a56	335	return;
567c915b TK	336	}
567c915b TK	337
21d1335b TB	338	dest = retarray->base_addr;
21d1335b TB	339	base = array->base_addr;
567c915b TK	340
	341	while (base)
	342	{
	343	const GFC_INTEGER_1 * restrict src;
28dc6b33	344	const GFC_LOGICAL_1 * restrict msrc;
567c915b TK	345	GFC_INTEGER_1 result;
	346	src = base;
	347	msrc = mbase;
	348	{
	349
80927a56 JJ	350	#if defined (GFC_INTEGER_1_INFINITY)
	351	result = -GFC_INTEGER_1_INFINITY;
	352	#else
	353	result = (-GFC_INTEGER_1_HUGE-1);
	354	#endif
	355	#if defined (GFC_INTEGER_1_QUIET_NAN)
	356	int non_empty_p = 0;
	357	#endif
036e1775	358	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
567c915b	359	{
567c915b	360
80927a56 JJ	361	#if defined (GFC_INTEGER_1_INFINITY) \|\| defined (GFC_INTEGER_1_QUIET_NAN)
	362	if (*msrc)
	363	{
	364	#if defined (GFC_INTEGER_1_QUIET_NAN)
	365	non_empty_p = 1;
	366	if (*src >= result)
	367	#endif
	368	break;
	369	}
	370	}
	371	if (unlikely (n >= len))
	372	{
	373	#if defined (GFC_INTEGER_1_QUIET_NAN)
	374	result = non_empty_p ? GFC_INTEGER_1_QUIET_NAN : (-GFC_INTEGER_1_HUGE-1);
	375	#else
	376	result = (-GFC_INTEGER_1_HUGE-1);
	377	#endif
	378	}
	379	else for (; n < len; n++, src += delta, msrc += mdelta)
	380	{
	381	#endif
	382	if (msrc && src > result)
	383	result = *src;
567c915b	384	}
036e1775	385	*dest = result;
567c915b TK	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])
80927a56 JJ	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++;
80dd631f	404	if (n >= rank)
80927a56	405	{
80dd631f	406	/* Break out of the loop. */
80927a56 JJ	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	}
567c915b TK	418	}
	419	}
	420
	421
	422	extern void smaxval_i1 (gfc_array_i1 * const restrict,
	423	gfc_array_i1 * const restrict, const index_type * const restrict,
	424	GFC_LOGICAL_4 *);
	425	export_proto(smaxval_i1);
	426
	427	void
	428	smaxval_i1 (gfc_array_i1 * const restrict retarray,
	429	gfc_array_i1 * const restrict array,
	430	const index_type * const restrict pdim,
	431	GFC_LOGICAL_4 * mask)
	432	{
802367d7 TK	433	index_type count[GFC_MAX_DIMENSIONS];
802367d7 TK	434	index_type extent[GFC_MAX_DIMENSIONS];
802367d7 TK	435	index_type dstride[GFC_MAX_DIMENSIONS];
802367d7 TK	436	GFC_INTEGER_1 * restrict dest;
567c915b TK	437	index_type rank;
567c915b TK	438	index_type n;
802367d7 TK	439	index_type dim;
802367d7 TK	440
567c915b TK	441
	442	if (*mask)
	443	{
	444	maxval_i1 (retarray, array, pdim);
	445	return;
	446	}
802367d7 TK	447	/* Make dim zero based to avoid confusion. */
	448	dim = (*pdim) - 1;
	449	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	450
cfdf6ff6 TK	451	if (unlikely (dim < 0 \|\| dim > rank))
	452	{
	453	runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
	454	"is %ld, should be between 1 and %ld",
	455	(long int) dim + 1, (long int) rank + 1);
	456	}
	457
802367d7 TK	458	for (n = 0; n < dim; n++)
802367d7 TK	459	{
dfb55fdc	460	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
802367d7 TK	461
	462	if (extent[n] <= 0)
	463	extent[n] = 0;
	464	}
	465
	466	for (n = dim; n < rank; n++)
	467	{
802367d7	468	extent[n] =
80927a56	469	GFC_DESCRIPTOR_EXTENT(array,n + 1);
802367d7 TK	470
802367d7 TK	471	if (extent[n] <= 0)
80927a56	472	extent[n] = 0;
802367d7	473	}
567c915b	474
21d1335b	475	if (retarray->base_addr == NULL)
567c915b	476	{
dfb55fdc	477	size_t alloc_size, str;
802367d7 TK	478
802367d7 TK	479	for (n = 0; n < rank; n++)
80927a56 JJ	480	{
	481	if (n == 0)
	482	str = 1;
	483	else
	484	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	485
	486	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	487
80927a56	488	}
802367d7	489
567c915b	490	retarray->offset = 0;
802367d7 TK	491	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
802367d7 TK	492
92e6f3a4	493	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
802367d7 TK	494
	495	if (alloc_size == 0)
	496	{
	497	/* Make sure we have a zero-sized array. */
dfb55fdc	498	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
802367d7 TK	499	return;
	500	}
	501	else
92e6f3a4	502	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_1));
567c915b 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;
567c915b	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	}
567c915b	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_1_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	}
567c915b TK	560	}
	561
	562	#endif