[gcc.git] / libgfortran / generated / minval_r8.c

/* Implementation of the MINVAL intrinsic
   Copyright (C) 2002-2015 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_8) && defined (HAVE_GFC_REAL_8)


extern void minval_r8 (gfc_array_r8 * const restrict, 
	gfc_array_r8 * const restrict, const index_type * const restrict);
export_proto(minval_r8);

void
minval_r8 (gfc_array_r8 * const restrict retarray, 
	gfc_array_r8 * 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_8 * restrict base;
  GFC_REAL_8 * 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 = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

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

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

#if defined (GFC_REAL_8_QUIET_NAN)
		if (*src <= result)
		  break;
	      }
	    if (unlikely (n >= len))
	      result = GFC_REAL_8_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_r8 (gfc_array_r8 * const restrict, 
	gfc_array_r8 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mminval_r8);

void
mminval_r8 (gfc_array_r8 * const restrict retarray, 
	gfc_array_r8 * 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_8 * restrict dest;
  const GFC_REAL_8 * 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 = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

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

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

#if defined (GFC_REAL_8_INFINITY)
	result = GFC_REAL_8_INFINITY;
#else
	result = GFC_REAL_8_HUGE;
#endif
#if defined (GFC_REAL_8_QUIET_NAN)
	int non_empty_p = 0;
#endif
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

#if defined (GFC_REAL_8_INFINITY) || defined (GFC_REAL_8_QUIET_NAN)
		if (*msrc)
		  {
#if defined (GFC_REAL_8_QUIET_NAN)
		    non_empty_p = 1;
		    if (*src <= result)
#endif
		      break;
		  }
	      }
	    if (unlikely (n >= len))
	      {
#if defined (GFC_REAL_8_QUIET_NAN)
		result = non_empty_p ? GFC_REAL_8_QUIET_NAN : GFC_REAL_8_HUGE;
#else
		result = GFC_REAL_8_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_r8 (gfc_array_r8 * const restrict, 
	gfc_array_r8 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sminval_r8);

void
sminval_r8 (gfc_array_r8 * const restrict retarray, 
	gfc_array_r8 * 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_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


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