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

/* Implementation of the MINVAL intrinsic
   Copyright 2002, 2007, 2009, 2010 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"
#include <stdlib.h>
#include <assert.h>


#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16)


extern void minval_r16 (gfc_array_r16 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict);
export_proto(minval_r16);

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

  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 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 = sizeof (GFC_REAL_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
    		   * extent[rank-1];

      retarray->base_addr = xmalloc (alloc_size);
      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_16 * restrict src;
      GFC_REAL_16 result;
      src = base;
      {

#if defined (GFC_REAL_16_INFINITY)
	result = GFC_REAL_16_INFINITY;
#else
	result = GFC_REAL_16_HUGE;
#endif
	if (len <= 0)
	  *dest = GFC_REAL_16_HUGE;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

#if defined (GFC_REAL_16_QUIET_NAN)
		if (*src <= result)
		  break;
	      }
	    if (unlikely (n >= len))
	      result = GFC_REAL_16_QUIET_NAN;
	    else for (; n < len; n++, src += delta)
	      {
#endif
		if (*src < result)
		  result = *src;
	      }
	    
	    *dest = result;
	  }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
	{
	  /* When we get to the end of a dimension, reset it and increment
	     the next dimension.  */
	  count[n] = 0;
	  /* We could precalculate these products, but this is a less
	     frequently used path so probably not worth it.  */
	  base -= sstride[n] * extent[n];
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n == rank)
	    {
	      /* Break out of the look.  */
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void mminval_r16 (gfc_array_r16 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mminval_r16);

void
mminval_r16 (gfc_array_r16 * const restrict retarray, 
	gfc_array_r16 * 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_16 * restrict dest;
  const GFC_REAL_16 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  int rank;
  int 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;

  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 = sizeof (GFC_REAL_16) * 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 = xmalloc (alloc_size);

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

#if defined (GFC_REAL_16_INFINITY)
	result = GFC_REAL_16_INFINITY;
#else
	result = GFC_REAL_16_HUGE;
#endif
#if defined (GFC_REAL_16_QUIET_NAN)
	int non_empty_p = 0;
#endif
	if (len <= 0)
	  *dest = GFC_REAL_16_HUGE;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

#if defined (GFC_REAL_16_INFINITY) || defined (GFC_REAL_16_QUIET_NAN)
		if (*msrc)
		  {
#if defined (GFC_REAL_16_QUIET_NAN)
		    non_empty_p = 1;
		    if (*src <= result)
#endif
		      break;
		  }
	      }
	    if (unlikely (n >= len))
	      {
#if defined (GFC_REAL_16_QUIET_NAN)
		result = non_empty_p ? GFC_REAL_16_QUIET_NAN : GFC_REAL_16_HUGE;
#else
		result = GFC_REAL_16_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 look.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void sminval_r16 (gfc_array_r16 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sminval_r16);

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


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