[thirdparty/gcc.git] / libgfortran / generated / maxval_i4.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_4) && defined (HAVE_GFC_INTEGER_4)


extern void maxval_i4 (gfc_array_i4 * const restrict, 
	gfc_array_i4 * const restrict, const index_type * const restrict);
export_proto(maxval_i4);

void
maxval_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * 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_4 * restrict base;
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

#ifdef HAVE_BACK_ARG
  assert(back == 0);
#endif

  /* 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;
      GFC_DTYPE_COPY_SETRANK(retarray,array,rank);

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

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

	}
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " MAXVAL intrinsic: is %ld, should be %ld",
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
		       (long int) rank);

      if (unlikely (compile_options.bounds_check))
	bounds_ifunction_return ((array_t *) retarray, extent,
				 "return value", "MAXVAL");
    }

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

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

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

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

#if defined (GFC_INTEGER_4_QUIET_NAN)
		if (*src >= result)
		  break;
	      }
	    if (unlikely (n >= len))
	      result = GFC_INTEGER_4_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_i4 (gfc_array_i4 * const restrict, 
	gfc_array_i4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxval_i4);

void
mmaxval_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * 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_4 * restrict dest;
  const GFC_INTEGER_4 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

#ifdef HAVE_BACK_ARG
  assert (back == 0);
#endif
  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;
      GFC_DTYPE_COPY_SETRANK(retarray,array,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_4));

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

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

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

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

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

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

#if defined (GFC_INTEGER_4_INFINITY) || defined (GFC_INTEGER_4_QUIET_NAN)
		if (*msrc)
		  {
#if defined (GFC_INTEGER_4_QUIET_NAN)
		    non_empty_p = 1;
		    if (*src >= result)
#endif
		      break;
		  }
	      }
	    if (unlikely (n >= len))
	      {
#if defined (GFC_INTEGER_4_QUIET_NAN)
		result = non_empty_p ? GFC_INTEGER_4_QUIET_NAN : (-GFC_INTEGER_4_HUGE-1);
#else
		result = (-GFC_INTEGER_4_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_i4 (gfc_array_i4 * const restrict, 
	gfc_array_i4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxval_i4);

void
smaxval_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * 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_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
#ifdef HAVE_BACK_ARG
      maxval_i4 (retarray, array, pdim, back);
#else
      maxval_i4 (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;
      GFC_DTYPE_COPY_SETRANK(retarray,array,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_4));
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " MAXVAL intrinsic: is %ld, should be %ld",
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
		       (long int) rank);

      if (unlikely (compile_options.bounds_check))
	{
	  for (n=0; n < rank; n++)
	    {
	      index_type ret_extent;

	      ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	      if (extent[n] != ret_extent)
		runtime_error ("Incorrect extent in return value of"
			       " MAXVAL intrinsic in dimension %ld:"
			       " is %ld, should be %ld", (long int) n + 1,
			       (long int) ret_extent, (long int) extent[n]);
	    }
	}
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
    }

  dest = retarray->base_addr;

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