[thirdparty/gcc.git] / libgfortran / generated / maxval_r17.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_REAL_17) && defined (HAVE_GFC_REAL_17)


extern void maxval_r17 (gfc_array_r17 * const restrict, 
	gfc_array_r17 * const restrict, const index_type * const restrict);
export_proto(maxval_r17);

void
maxval_r17 (gfc_array_r17 * const restrict retarray, 
	gfc_array_r17 * 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_REAL_17 * restrict base;
  GFC_REAL_17 * 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_REAL_17));
      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_REAL_17 * restrict src;
      GFC_REAL_17 result;
      src = base;
      {

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

#if defined (GFC_REAL_17_QUIET_NAN)
		if (*src >= result)
		  break;
	      }
	    if (unlikely (n >= len))
	      result = GFC_REAL_17_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_r17 (gfc_array_r17 * const restrict, 
	gfc_array_r17 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxval_r17);

void
mmaxval_r17 (gfc_array_r17 * const restrict retarray, 
	gfc_array_r17 * 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_REAL_17 * restrict dest;
  const GFC_REAL_17 * 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_r17 (retarray, array, pdim, back);
#else
      maxval_r17 (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_REAL_17));
      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_REAL_17 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_REAL_17 result;
      src = base;
      msrc = mbase;
      {

#if defined (GFC_REAL_17_INFINITY)
	result = -GFC_REAL_17_INFINITY;
#else
	result = -GFC_REAL_17_HUGE;
#endif
#if defined (GFC_REAL_17_QUIET_NAN)
	int non_empty_p = 0;
#endif
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

#if defined (GFC_REAL_17_INFINITY) || defined (GFC_REAL_17_QUIET_NAN)
		if (*msrc)
		  {
#if defined (GFC_REAL_17_QUIET_NAN)
		    non_empty_p = 1;
		    if (*src >= result)
#endif
		      break;
		  }
	      }
	    if (unlikely (n >= len))
	      {
#if defined (GFC_REAL_17_QUIET_NAN)
		result = non_empty_p ? GFC_REAL_17_QUIET_NAN : -GFC_REAL_17_HUGE;
#else
		result = -GFC_REAL_17_HUGE;
#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_r17 (gfc_array_r17 * const restrict, 
	gfc_array_r17 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxval_r17);

void
smaxval_r17 (gfc_array_r17 * const restrict retarray, 
	gfc_array_r17 * 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_REAL_17 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      maxval_r17 (retarray, array, pdim, back);
#else
      maxval_r17 (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_REAL_17));
      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_REAL_17_HUGE;
      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
49ad4d2c	1	/* Implementation of the MAXVAL intrinsic
a945c346	2	Copyright (C) 2002-2024 Free Software Foundation, Inc.
49ad4d2c TK	3	Contributed by Paul Brook <paul@nowt.org>
	4
	5	This file is part of the GNU Fortran runtime library (libgfortran).
	6
	7	Libgfortran is free software; you can redistribute it and/or
	8	modify it under the terms of the GNU General Public
	9	License as published by the Free Software Foundation; either
	10	version 3 of the License, or (at your option) any later version.
	11
	12	Libgfortran is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
	16
	17	Under Section 7 of GPL version 3, you are granted additional
	18	permissions described in the GCC Runtime Library Exception, version
	19	3.1, as published by the Free Software Foundation.
	20
	21	You should have received a copy of the GNU General Public License and
	22	a copy of the GCC Runtime Library Exception along with this program;
	23	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	24	<http://www.gnu.org/licenses/>. */
	25
	26	#include "libgfortran.h"
	27
	28
	29	#if defined (HAVE_GFC_REAL_17) && defined (HAVE_GFC_REAL_17)
	30
	31
	32	extern void maxval_r17 (gfc_array_r17 * const restrict,
	33	gfc_array_r17 * const restrict, const index_type * const restrict);
	34	export_proto(maxval_r17);
	35
	36	void
	37	maxval_r17 (gfc_array_r17 * const restrict retarray,
	38	gfc_array_r17 * 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_REAL_17 * restrict base;
	46	GFC_REAL_17 * restrict dest;
	47	index_type rank;
	48	index_type n;
	49	index_type len;
	50	index_type delta;
	51	index_type dim;
	52	int continue_loop;
	53
	54	/* Make dim zero based to avoid confusion. */
	55	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	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	}
	64
	65	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	66	if (len < 0)
67	len = 0;
68	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
69
70	for (n = 0; n < dim; n++)
71	{
72	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
73	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
74
75	if (extent[n] < 0)
76	extent[n] = 0;
77	}
78	for (n = dim; n < rank; n++)
79	{
80	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
81	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
82
83	if (extent[n] < 0)
84	extent[n] = 0;
85	}
86
87	if (retarray->base_addr == NULL)
88	{
89	size_t alloc_size, str;
90
91	for (n = 0; n < rank; n++)
92	{
93	if (n == 0)
94	str = 1;
95	else
96	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
97
98	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
99
100	}
101
102	retarray->offset = 0;
103	retarray->dtype.rank = rank;
104
105	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
106
107	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_17));
108	if (alloc_size == 0)
62715bf8	109	return;
49ad4d2c TK	110	}
	111	else
	112	{
	113	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	114	runtime_error ("rank of return array incorrect in"
	115	" MAXVAL intrinsic: is %ld, should be %ld",
	116	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	117	(long int) rank);
	118
	119	if (unlikely (compile_options.bounds_check))
	120	bounds_ifunction_return ((array_t *) retarray, extent,
	121	"return value", "MAXVAL");
	122	}
	123
	124	for (n = 0; n < rank; n++)
	125	{
	126	count[n] = 0;
	127	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	128	if (extent[n] <= 0)
	129	return;
	130	}
	131
	132	base = array->base_addr;
	133	dest = retarray->base_addr;
	134
	135	continue_loop = 1;
	136	while (continue_loop)
	137	{
	138	const GFC_REAL_17 * restrict src;
	139	GFC_REAL_17 result;
	140	src = base;
	141	{
	142
	143	#if defined (GFC_REAL_17_INFINITY)
	144	result = -GFC_REAL_17_INFINITY;
	145	#else
	146	result = -GFC_REAL_17_HUGE;
	147	#endif
	148	if (len <= 0)
	149	*dest = -GFC_REAL_17_HUGE;
	150	else
	151	{
	152	#if ! defined HAVE_BACK_ARG
	153	for (n = 0; n < len; n++, src += delta)
	154	{
	155	#endif
	156
	157	#if defined (GFC_REAL_17_QUIET_NAN)
	158	if (*src >= result)
	159	break;
	160	}
	161	if (unlikely (n >= len))
	162	result = GFC_REAL_17_QUIET_NAN;
	163	else for (; n < len; n++, src += delta)
	164	{
	165	#endif
	166	if (*src > result)
	167	result = *src;
	168	}
	169
	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])
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++;
188	if (n >= rank)
189	{
190	/* Break out of the loop. */
191	continue_loop = 0;
192	break;
193	}
194	else
195	{
196	count[n]++;
197	base += sstride[n];
198	dest += dstride[n];
199	}
200	}
201	}
202	}
203
204
205	extern void mmaxval_r17 (gfc_array_r17 * const restrict,
206	gfc_array_r17 * const restrict, const index_type * const restrict,
207	gfc_array_l1 * const restrict);
208	export_proto(mmaxval_r17);
209
210	void
211	mmaxval_r17 (gfc_array_r17 * const restrict retarray,
212	gfc_array_r17 * const restrict array,
213	const index_type * const restrict pdim,
214	gfc_array_l1 * const restrict mask)
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];
221	GFC_REAL_17 * restrict dest;
222	const GFC_REAL_17 * restrict base;
223	const GFC_LOGICAL_1 * restrict mbase;
224	index_type rank;
225	index_type dim;
226	index_type n;
227	index_type len;
228	index_type delta;
229	index_type mdelta;
230	int mask_kind;
231
232	if (mask == NULL)
233	{
234	#ifdef HAVE_BACK_ARG
235	maxval_r17 (retarray, array, pdim, back);
236	#else
237	maxval_r17 (retarray, array, pdim);
238	#endif
239	return;
240	}
241
242	dim = (*pdim) - 1;
243	rank = GFC_DESCRIPTOR_RANK (array) - 1;
244
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
253	len = GFC_DESCRIPTOR_EXTENT(array,dim);
85a96881 MM	254	if (len < 0)
85a96881 MM	255	len = 0;
49ad4d2c TK	256
	257	mbase = mask->base_addr;
	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
	270	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
	271	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	272
	273	for (n = 0; n < dim; n++)
	274	{
	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);
	278
	279	if (extent[n] < 0)
	280	extent[n] = 0;
	281
	282	}
	283	for (n = dim; n < rank; n++)
	284	{
	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);
	288
	289	if (extent[n] < 0)
	290	extent[n] = 0;
	291	}
	292
	293	if (retarray->base_addr == NULL)
	294	{
	295	size_t alloc_size, str;
	296
	297	for (n = 0; n < rank; n++)
	298	{
	299	if (n == 0)
	300	str = 1;
	301	else
	302	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	303
	304	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	305
	306	}
	307
	308	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
	309
	310	retarray->offset = 0;
	311	retarray->dtype.rank = rank;
	312
d56bf419	313	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_17));
49ad4d2c	314	if (alloc_size == 0)
62715bf8	315	return;
49ad4d2c TK	316	}
	317	else
	318	{
	319	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	320	runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
	321
	322	if (unlikely (compile_options.bounds_check))
	323	{
	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");
	328	}
	329	}
	330
	331	for (n = 0; n < rank; n++)
	332	{
	333	count[n] = 0;
	334	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	335	if (extent[n] <= 0)
	336	return;
	337	}
	338
	339	dest = retarray->base_addr;
	340	base = array->base_addr;
	341
	342	while (base)
	343	{
	344	const GFC_REAL_17 * restrict src;
	345	const GFC_LOGICAL_1 * restrict msrc;
	346	GFC_REAL_17 result;
	347	src = base;
	348	msrc = mbase;
	349	{
	350
	351	#if defined (GFC_REAL_17_INFINITY)
	352	result = -GFC_REAL_17_INFINITY;
	353	#else
	354	result = -GFC_REAL_17_HUGE;
	355	#endif
	356	#if defined (GFC_REAL_17_QUIET_NAN)
	357	int non_empty_p = 0;
	358	#endif
	359	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	360	{
	361
	362	#if defined (GFC_REAL_17_INFINITY) \|\| defined (GFC_REAL_17_QUIET_NAN)
	363	if (*msrc)
	364	{
	365	#if defined (GFC_REAL_17_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_REAL_17_QUIET_NAN)
	375	result = non_empty_p ? GFC_REAL_17_QUIET_NAN : -GFC_REAL_17_HUGE;
	376	#else
	377	result = -GFC_REAL_17_HUGE;
	378	#endif
	379	}
380	else for (; n < len; n++, src += delta, msrc += mdelta)
381	{
382	#endif
383	if (msrc && src > result)
384	result = *src;
385	}
386	*dest = result;
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])
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++;
405	if (n >= rank)
406	{
407	/* Break out of the loop. */
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	}
419	}
420	}
421
422
423	extern void smaxval_r17 (gfc_array_r17 * const restrict,
424	gfc_array_r17 * const restrict, const index_type * const restrict,
425	GFC_LOGICAL_4 *);
426	export_proto(smaxval_r17);
427
428	void
429	smaxval_r17 (gfc_array_r17 * const restrict retarray,
430	gfc_array_r17 * const restrict array,
431	const index_type * const restrict pdim,
432	GFC_LOGICAL_4 * mask)
433	{
434	index_type count[GFC_MAX_DIMENSIONS];
435	index_type extent[GFC_MAX_DIMENSIONS];
436	index_type dstride[GFC_MAX_DIMENSIONS];
437	GFC_REAL_17 * restrict dest;
438	index_type rank;
439	index_type n;
440	index_type dim;
441
442
443	if (mask == NULL \|\| *mask)
444	{
445	#ifdef HAVE_BACK_ARG
446	maxval_r17 (retarray, array, pdim, back);
447	#else
448	maxval_r17 (retarray, array, pdim);
449	#endif
450	return;
451	}
452	/* Make dim zero based to avoid confusion. */
453	dim = (*pdim) - 1;
454	rank = GFC_DESCRIPTOR_RANK (array) - 1;
455
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
463	for (n = 0; n < dim; n++)
464	{
465	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
466
467	if (extent[n] <= 0)
468	extent[n] = 0;
469	}
470
471	for (n = dim; n < rank; n++)
472	{
473	extent[n] =
474	GFC_DESCRIPTOR_EXTENT(array,n + 1);
475
476	if (extent[n] <= 0)
477	extent[n] = 0;
478	}
479
480	if (retarray->base_addr == NULL)
481	{
482	size_t alloc_size, str;
483
484	for (n = 0; n < rank; n++)
485	{
486	if (n == 0)
487	str = 1;
488	else
489	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
490
491	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
492
493	}
494
495	retarray->offset = 0;
496	retarray->dtype.rank = rank;
497
498	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
499
d56bf419	500	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_17));
49ad4d2c	501	if (alloc_size == 0)
62715bf8	502	return;
49ad4d2c TK	503	}
	504	else
	505	{
	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
	512	if (unlikely (compile_options.bounds_check))
	513	{
	514	for (n=0; n < rank; n++)
	515	{
	516	index_type ret_extent;
	517
	518	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	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	}
	525	}
	526	}
	527
	528	for (n = 0; n < rank; n++)
	529	{
	530	count[n] = 0;
	531	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	532	}
	533
	534	dest = retarray->base_addr;
	535
	536	while(1)
	537	{
	538	*dest = -GFC_REAL_17_HUGE;
	539	count[0]++;
	540	dest += dstride[0];
	541	n = 0;
	542	while (count[n] == extent[n])
	543	{
	544	/* When we get to the end of a dimension, reset it and increment
	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++;
	551	if (n >= rank)
	552	return;
	553	else
	554	{
	555	count[n]++;
	556	dest += dstride[n];
	557	}
	558	}
	559	}
	560	}
	561
	562	#endif