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

/* Implementation of the MINVAL intrinsic
   Copyright (C) 2002-2023 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 minval_r17 (gfc_array_r17 * const restrict, 
	gfc_array_r17 * const restrict, const index_type * const restrict);
export_proto(minval_r17);

void
minval_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 MINVAL 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)
	{
	  /* 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"
		       " MINVAL 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", "MINVAL");
    }

  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 mminval_r17 (gfc_array_r17 * const restrict, 
	gfc_array_r17 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mminval_r17);

void
mminval_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
      minval_r17 (retarray, array, pdim, back);
#else
      minval_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 MINVAL intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len <= 0)
    return;

  mbase = mask->base_addr;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

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

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

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

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

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

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

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

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

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

	}

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

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

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

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

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

  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 sminval_r17 (gfc_array_r17 * const restrict, 
	gfc_array_r17 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sminval_r17);

void
sminval_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
      minval_r17 (retarray, array, pdim, back);
#else
      minval_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 MINVAL intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

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

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

  for (n = dim; n < rank; n++)
    {
      extent[n] =
	GFC_DESCRIPTOR_EXTENT(array,n + 1);

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

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

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

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

	}

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

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

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_17));
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " MINVAL 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"
			       " MINVAL 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 MINVAL intrinsic
83ffe9cd	2	Copyright (C) 2002-2023 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 minval_r17 (gfc_array_r17 * const restrict,
	33	gfc_array_r17 * const restrict, const index_type * const restrict);
	34	export_proto(minval_r17);
	35
	36	void
	37	minval_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 MINVAL 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)
109	{
110	/* Make sure we have a zero-sized array. */
111	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
112	return;
113
114	}
115	}
116	else
117	{
118	if (rank != GFC_DESCRIPTOR_RANK (retarray))
119	runtime_error ("rank of return array incorrect in"
120	" MINVAL intrinsic: is %ld, should be %ld",
121	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
122	(long int) rank);
123
124	if (unlikely (compile_options.bounds_check))
125	bounds_ifunction_return ((array_t *) retarray, extent,
126	"return value", "MINVAL");
127	}
128
129	for (n = 0; n < rank; n++)
130	{
131	count[n] = 0;
132	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
133	if (extent[n] <= 0)
134	return;
135	}
136
137	base = array->base_addr;
138	dest = retarray->base_addr;
139
140	continue_loop = 1;
141	while (continue_loop)
142	{
143	const GFC_REAL_17 * restrict src;
144	GFC_REAL_17 result;
145	src = base;
146	{
147
148	#if defined (GFC_REAL_17_INFINITY)
149	result = GFC_REAL_17_INFINITY;
150	#else
151	result = GFC_REAL_17_HUGE;
152	#endif
153	if (len <= 0)
154	*dest = GFC_REAL_17_HUGE;
155	else
156	{
157	#if ! defined HAVE_BACK_ARG
158	for (n = 0; n < len; n++, src += delta)
159	{
160	#endif
161
162	#if defined (GFC_REAL_17_QUIET_NAN)
163	if (*src <= result)
164	break;
165	}
166	if (unlikely (n >= len))
167	result = GFC_REAL_17_QUIET_NAN;
168	else for (; n < len; n++, src += delta)
169	{
170	#endif
171	if (*src < result)
172	result = *src;
173	}
174
175	*dest = result;
176	}
177	}
178	/* Advance to the next element. */
179	count[0]++;
180	base += sstride[0];
181	dest += dstride[0];
182	n = 0;
183	while (count[n] == extent[n])
184	{
185	/* When we get to the end of a dimension, reset it and increment
186	the next dimension. */
187	count[n] = 0;
188	/* We could precalculate these products, but this is a less
189	frequently used path so probably not worth it. */
190	base -= sstride[n] * extent[n];
191	dest -= dstride[n] * extent[n];
192	n++;
193	if (n >= rank)
194	{
195	/* Break out of the loop. */
196	continue_loop = 0;
197	break;
198	}
199	else
200	{
201	count[n]++;
202	base += sstride[n];
203	dest += dstride[n];
204	}
205	}
206	}
207	}
208
209
210	extern void mminval_r17 (gfc_array_r17 * const restrict,
211	gfc_array_r17 * const restrict, const index_type * const restrict,
212	gfc_array_l1 * const restrict);
213	export_proto(mminval_r17);
214
215	void
216	mminval_r17 (gfc_array_r17 * const restrict retarray,
217	gfc_array_r17 * const restrict array,
218	const index_type * const restrict pdim,
219	gfc_array_l1 * const restrict mask)
220	{
221	index_type count[GFC_MAX_DIMENSIONS];
222	index_type extent[GFC_MAX_DIMENSIONS];
223	index_type sstride[GFC_MAX_DIMENSIONS];
224	index_type dstride[GFC_MAX_DIMENSIONS];
225	index_type mstride[GFC_MAX_DIMENSIONS];
226	GFC_REAL_17 * restrict dest;
227	const GFC_REAL_17 * restrict base;
228	const GFC_LOGICAL_1 * restrict mbase;
229	index_type rank;
230	index_type dim;
231	index_type n;
232	index_type len;
233	index_type delta;
234	index_type mdelta;
235	int mask_kind;
236
237	if (mask == NULL)
238	{
239	#ifdef HAVE_BACK_ARG
240	minval_r17 (retarray, array, pdim, back);
241	#else
242	minval_r17 (retarray, array, pdim);
243	#endif
244	return;
245	}
246
247	dim = (*pdim) - 1;
248	rank = GFC_DESCRIPTOR_RANK (array) - 1;
249
250
251	if (unlikely (dim < 0 \|\| dim > rank))
252	{
253	runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
254	"is %ld, should be between 1 and %ld",
255	(long int) dim + 1, (long int) rank + 1);
256	}
257
258	len = GFC_DESCRIPTOR_EXTENT(array,dim);
259	if (len <= 0)
260	return;
261
262	mbase = mask->base_addr;
263
264	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
265
266	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
267	#ifdef HAVE_GFC_LOGICAL_16
268	\|\| mask_kind == 16
269	#endif
270	)
271	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
272	else
273	runtime_error ("Funny sized logical array");
274
275	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
276	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
277
278	for (n = 0; n < dim; n++)
279	{
280	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
281	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
282	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
283
284	if (extent[n] < 0)
285	extent[n] = 0;
286
287	}
288	for (n = dim; n < rank; n++)
289	{
290	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
291	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
292	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
293
294	if (extent[n] < 0)
295	extent[n] = 0;
296	}
297
298	if (retarray->base_addr == NULL)
299	{
300	size_t alloc_size, str;
301
302	for (n = 0; n < rank; n++)
303	{
304	if (n == 0)
305	str = 1;
306	else
307	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
308
309	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
310
311	}
312
313	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
314
315	retarray->offset = 0;
316	retarray->dtype.rank = rank;
317
318	if (alloc_size == 0)
319	{
320	/* Make sure we have a zero-sized array. */
321	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
322	return;
323	}
324	else
325	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_17));
326
327	}
328	else
329	{
330	if (rank != GFC_DESCRIPTOR_RANK (retarray))
331	runtime_error ("rank of return array incorrect in MINVAL intrinsic");
332
333	if (unlikely (compile_options.bounds_check))
334	{
335	bounds_ifunction_return ((array_t *) retarray, extent,
336	"return value", "MINVAL");
337	bounds_equal_extents ((array_t ) mask, (array_t ) array,
338	"MASK argument", "MINVAL");
339	}
340	}
341
342	for (n = 0; n < rank; n++)
343	{
344	count[n] = 0;
345	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
346	if (extent[n] <= 0)
347	return;
348	}
349
350	dest = retarray->base_addr;
351	base = array->base_addr;
352
353	while (base)
354	{
355	const GFC_REAL_17 * restrict src;
356	const GFC_LOGICAL_1 * restrict msrc;
357	GFC_REAL_17 result;
358	src = base;
359	msrc = mbase;
360	{
361
362	#if defined (GFC_REAL_17_INFINITY)
363	result = GFC_REAL_17_INFINITY;
364	#else
365	result = GFC_REAL_17_HUGE;
366	#endif
367	#if defined (GFC_REAL_17_QUIET_NAN)
368	int non_empty_p = 0;
369	#endif
370	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
371	{
372
373	#if defined (GFC_REAL_17_INFINITY) \|\| defined (GFC_REAL_17_QUIET_NAN)
374	if (*msrc)
375	{
376	#if defined (GFC_REAL_17_QUIET_NAN)
377	non_empty_p = 1;
378	if (*src <= result)
379	#endif
380	break;
381	}
382	}
383	if (unlikely (n >= len))
384	{
385	#if defined (GFC_REAL_17_QUIET_NAN)
386	result = non_empty_p ? GFC_REAL_17_QUIET_NAN : GFC_REAL_17_HUGE;
387	#else
388	result = GFC_REAL_17_HUGE;
389	#endif
390	}
391	else for (; n < len; n++, src += delta, msrc += mdelta)
392	{
393	#endif
394	if (msrc && src < result)
395	result = *src;
396	}
397	*dest = result;
398	}
399	/* Advance to the next element. */
400	count[0]++;
401	base += sstride[0];
402	mbase += mstride[0];
403	dest += dstride[0];
404	n = 0;
405	while (count[n] == extent[n])
406	{
407	/* When we get to the end of a dimension, reset it and increment
408	the next dimension. */
409	count[n] = 0;
410	/* We could precalculate these products, but this is a less
411	frequently used path so probably not worth it. */
412	base -= sstride[n] * extent[n];
413	mbase -= mstride[n] * extent[n];
414	dest -= dstride[n] * extent[n];
415	n++;
416	if (n >= rank)
417	{
418	/* Break out of the loop. */
419	base = NULL;
420	break;
421	}
422	else
423	{
424	count[n]++;
425	base += sstride[n];
426	mbase += mstride[n];
427	dest += dstride[n];
428	}
429	}
430	}
431	}
432
433
434	extern void sminval_r17 (gfc_array_r17 * const restrict,
435	gfc_array_r17 * const restrict, const index_type * const restrict,
436	GFC_LOGICAL_4 *);
437	export_proto(sminval_r17);
438
439	void
440	sminval_r17 (gfc_array_r17 * const restrict retarray,
441	gfc_array_r17 * const restrict array,
442	const index_type * const restrict pdim,
443	GFC_LOGICAL_4 * mask)
444	{
445	index_type count[GFC_MAX_DIMENSIONS];
446	index_type extent[GFC_MAX_DIMENSIONS];
447	index_type dstride[GFC_MAX_DIMENSIONS];
448	GFC_REAL_17 * restrict dest;
449	index_type rank;
450	index_type n;
451	index_type dim;
452
453
454	if (mask == NULL \|\| *mask)
455	{
456	#ifdef HAVE_BACK_ARG
457	minval_r17 (retarray, array, pdim, back);
458	#else
459	minval_r17 (retarray, array, pdim);
460	#endif
461	return;
462	}
463	/* Make dim zero based to avoid confusion. */
464	dim = (*pdim) - 1;
465	rank = GFC_DESCRIPTOR_RANK (array) - 1;
466
467	if (unlikely (dim < 0 \|\| dim > rank))
468	{
469	runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
470	"is %ld, should be between 1 and %ld",
471	(long int) dim + 1, (long int) rank + 1);
472	}
473
474	for (n = 0; n < dim; n++)
475	{
476	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
477
478	if (extent[n] <= 0)
479	extent[n] = 0;
480	}
481
482	for (n = dim; n < rank; n++)
483	{
484	extent[n] =
485	GFC_DESCRIPTOR_EXTENT(array,n + 1);
486
487	if (extent[n] <= 0)
488	extent[n] = 0;
489	}
490
491	if (retarray->base_addr == NULL)
492	{
493	size_t alloc_size, str;
494
495	for (n = 0; n < rank; n++)
496	{
497	if (n == 0)
498	str = 1;
499	else
500	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
501
502	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
503
504	}
505
506	retarray->offset = 0;
507	retarray->dtype.rank = rank;
508
509	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
510
511	if (alloc_size == 0)
512	{
513	/* Make sure we have a zero-sized array. */
514	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
515	return;
516	}
517	else
518	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_17));
519	}
520	else
521	{
522	if (rank != GFC_DESCRIPTOR_RANK (retarray))
523	runtime_error ("rank of return array incorrect in"
524	" MINVAL intrinsic: is %ld, should be %ld",
525	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
526	(long int) rank);
527
528	if (unlikely (compile_options.bounds_check))
529	{
530	for (n=0; n < rank; n++)
531	{
532	index_type ret_extent;
533
534	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
535	if (extent[n] != ret_extent)
536	runtime_error ("Incorrect extent in return value of"
537	" MINVAL intrinsic in dimension %ld:"
538	" is %ld, should be %ld", (long int) n + 1,
539	(long int) ret_extent, (long int) extent[n]);
540	}
541	}
542	}
543
544	for (n = 0; n < rank; n++)
545	{
546	count[n] = 0;
547	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
548	}
549
550	dest = retarray->base_addr;
551
552	while(1)
553	{
554	*dest = GFC_REAL_17_HUGE;
555	count[0]++;
556	dest += dstride[0];
557	n = 0;
558	while (count[n] == extent[n])
559	{
560	/* When we get to the end of a dimension, reset it and increment
561	the next dimension. */
562	count[n] = 0;
563	/* We could precalculate these products, but this is a less
564	frequently used path so probably not worth it. */
565	dest -= dstride[n] * extent[n];
566	n++;
567	if (n >= rank)
568	return;
569	else
570	{
571	count[n]++;
572	dest += dstride[n];
573	}
574	}
575	}
576	}
577
578	#endif