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


extern void minval_r4 (gfc_array_r4 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict);
export_proto(minval_r4);

void
minval_r4 (gfc_array_r4 * const restrict retarray, 
	gfc_array_r4 * 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_4 * restrict base;
  GFC_REAL_4 * 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_4));
      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;

	}
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " 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_4 * restrict src;
      GFC_REAL_4 result;
      src = base;
      {

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

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


extern void mminval_r4 (gfc_array_r4 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mminval_r4);

void
mminval_r4 (gfc_array_r4 * const restrict retarray, 
	gfc_array_r4 * 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_4 * restrict dest;
  const GFC_REAL_4 * 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_4));

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

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

#if defined (GFC_REAL_4_INFINITY) || defined (GFC_REAL_4_QUIET_NAN)
		if (*msrc)
		  {
#if defined (GFC_REAL_4_QUIET_NAN)
		    non_empty_p = 1;
		    if (*src <= result)
#endif
		      break;
		  }
	      }
	    if (unlikely (n >= len))
	      {
#if defined (GFC_REAL_4_QUIET_NAN)
		result = non_empty_p ? GFC_REAL_4_QUIET_NAN : GFC_REAL_4_HUGE;
#else
		result = GFC_REAL_4_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_r4 (gfc_array_r4 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sminval_r4);

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


  if (*mask)
    {
      minval_r4 (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_4));
    }
  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_4_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
4ee9c684	1	/* Implementation of the MINVAL intrinsic
d353bf18	2	Copyright (C) 2002-2015 Free Software Foundation, Inc.
4ee9c684	3	Contributed by Paul Brook <paul@nowt.org>
4ee9c684	4
b4ba8232	5	This file is part of the GNU Fortran runtime library (libgfortran).
4ee9c684	6
4ee9c684	7	Libgfortran is free software; you can redistribute it and/or
b417ea8c	8	modify it under the terms of the GNU General Public
4ee9c684	9	License as published by the Free Software Foundation; either
6bc9506f	10	version 3 of the License, or (at your option) any later version.
4ee9c684	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
b417ea8c	15	GNU General Public License for more details.
4ee9c684	16
6bc9506f	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/>. */
4ee9c684	25
41f2d5e8	26	#include "libgfortran.h"
4ee9c684	27	#include <stdlib.h>
4ee9c684	28	#include <assert.h>
4ee9c684	29
7b6cb5bd	30
920e54ef	31	#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4)
	32
	33
b4cafd67	34	extern void minval_r4 (gfc_array_r4 * const restrict,
b4cafd67	35	gfc_array_r4 * const restrict, const index_type * const restrict);
820b4fbd	36	export_proto(minval_r4);
7b6cb5bd	37
4ee9c684	38	void
b4cafd67	39	minval_r4 (gfc_array_r4 * const restrict retarray,
	40	gfc_array_r4 * const restrict array,
	41	const index_type * const restrict pdim)
4ee9c684	42	{
9130521e	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];
b4cafd67	47	const GFC_REAL_4 * restrict base;
b4cafd67	48	GFC_REAL_4 * restrict dest;
4ee9c684	49	index_type rank;
	50	index_type n;
	51	index_type len;
	52	index_type delta;
	53	index_type dim;
393a1b6c	54	int continue_loop;
4ee9c684	55
	56	/* Make dim zero based to avoid confusion. */
	57	dim = (*pdim) - 1;
	58	rank = GFC_DESCRIPTOR_RANK (array) - 1;
9130521e	59
827aef63	60	len = GFC_DESCRIPTOR_EXTENT(array,dim);
393a1b6c	61	if (len < 0)
393a1b6c	62	len = 0;
827aef63	63	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
4ee9c684	64
	65	for (n = 0; n < dim; n++)
	66	{
827aef63	67	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
827aef63	68	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
a14c06e9	69
	70	if (extent[n] < 0)
	71	extent[n] = 0;
4ee9c684	72	}
	73	for (n = dim; n < rank; n++)
	74	{
827aef63	75	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
827aef63	76	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
a14c06e9	77
	78	if (extent[n] < 0)
	79	extent[n] = 0;
4ee9c684	80	}
4ee9c684	81
553877d9	82	if (retarray->base_addr == NULL)
5fcc57ce	83	{
827aef63	84	size_t alloc_size, str;
a14c06e9	85
5fcc57ce	86	for (n = 0; n < rank; n++)
7ebee933	87	{
7ebee933	88	if (n == 0)
827aef63	89	str = 1;
7ebee933	90	else
7ebee933	91	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
827aef63	92
	93	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	94
7ebee933	95	}
5fcc57ce	96
93830de1	97	retarray->offset = 0;
07ea8faa	98	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
a14c06e9	99
af1e9051	100	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
a14c06e9	101
af1e9051	102	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_4));
a14c06e9	103	if (alloc_size == 0)
	104	{
	105	/* Make sure we have a zero-sized array. */
827aef63	106	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
a14c06e9	107	return;
827aef63	108
a14c06e9	109	}
5fcc57ce	110	}
07ea8faa	111	else
07ea8faa	112	{
07ea8faa	113	if (rank != GFC_DESCRIPTOR_RANK (retarray))
8dec97a0	114	runtime_error ("rank of return array incorrect in"
ae66f8f3	115	" MINVAL intrinsic: is %ld, should be %ld",
	116	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	117	(long int) rank);
8dec97a0	118
c7fb575f	119	if (unlikely (compile_options.bounds_check))
5d04d450	120	bounds_ifunction_return ((array_t *) retarray, extent,
5d04d450	121	"return value", "MINVAL");
07ea8faa	122	}
07ea8faa	123
4ee9c684	124	for (n = 0; n < rank; n++)
	125	{
	126	count[n] = 0;
827aef63	127	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
4ee9c684	128	if (extent[n] <= 0)
7cbf86e5	129	return;
4ee9c684	130	}
4ee9c684	131
553877d9	132	base = array->base_addr;
553877d9	133	dest = retarray->base_addr;
4ee9c684	134
393a1b6c	135	continue_loop = 1;
393a1b6c	136	while (continue_loop)
4ee9c684	137	{
b4cafd67	138	const GFC_REAL_4 * restrict src;
4ee9c684	139	GFC_REAL_4 result;
	140	src = base;
	141	{
	142
7ebee933	143	#if defined (GFC_REAL_4_INFINITY)
	144	result = GFC_REAL_4_INFINITY;
	145	#else
	146	result = GFC_REAL_4_HUGE;
	147	#endif
	148	if (len <= 0)
4ee9c684	149	*dest = GFC_REAL_4_HUGE;
	150	else
	151	{
	152	for (n = 0; n < len; n++, src += delta)
	153	{
	154
7ebee933	155	#if defined (GFC_REAL_4_QUIET_NAN)
	156	if (*src <= result)
	157	break;
	158	}
	159	if (unlikely (n >= len))
	160	result = GFC_REAL_4_QUIET_NAN;
	161	else for (; n < len; n++, src += delta)
	162	{
	163	#endif
	164	if (*src < result)
	165	result = *src;
	166	}
b4ba8232	167
4ee9c684	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])
7ebee933	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. */
393a1b6c	189	continue_loop = 0;
393a1b6c	190	break;
7ebee933	191	}
	192	else
	193	{
	194	count[n]++;
	195	base += sstride[n];
	196	dest += dstride[n];
	197	}
	198	}
4ee9c684	199	}
	200	}
	201
7b6cb5bd	202
b4cafd67	203	extern void mminval_r4 (gfc_array_r4 * const restrict,
b4cafd67	204	gfc_array_r4 * const restrict, const index_type * const restrict,
7ed8f627	205	gfc_array_l1 * const restrict);
820b4fbd	206	export_proto(mminval_r4);
7b6cb5bd	207
4ee9c684	208	void
b4cafd67	209	mminval_r4 (gfc_array_r4 * const restrict retarray,
	210	gfc_array_r4 * const restrict array,
	211	const index_type * const restrict pdim,
7ed8f627	212	gfc_array_l1 * const restrict mask)
4ee9c684	213	{
9130521e	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];
b4cafd67	219	GFC_REAL_4 * restrict dest;
b4cafd67	220	const GFC_REAL_4 * restrict base;
7ed8f627	221	const GFC_LOGICAL_1 * restrict mbase;
4ee9c684	222	int rank;
	223	int dim;
	224	index_type n;
	225	index_type len;
	226	index_type delta;
	227	index_type mdelta;
7ed8f627	228	int mask_kind;
4ee9c684	229
	230	dim = (*pdim) - 1;
	231	rank = GFC_DESCRIPTOR_RANK (array) - 1;
9130521e	232
827aef63	233	len = GFC_DESCRIPTOR_EXTENT(array,dim);
4ee9c684	234	if (len <= 0)
4ee9c684	235	return;
7ed8f627	236
553877d9	237	mbase = mask->base_addr;
7ed8f627	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
827aef63	250	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
827aef63	251	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
4ee9c684	252
	253	for (n = 0; n < dim; n++)
	254	{
827aef63	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);
a14c06e9	258
	259	if (extent[n] < 0)
	260	extent[n] = 0;
	261
4ee9c684	262	}
	263	for (n = dim; n < rank; n++)
	264	{
827aef63	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);
a14c06e9	268
	269	if (extent[n] < 0)
	270	extent[n] = 0;
4ee9c684	271	}
4ee9c684	272
553877d9	273	if (retarray->base_addr == NULL)
07ea8faa	274	{
827aef63	275	size_t alloc_size, str;
a14c06e9	276
07ea8faa	277	for (n = 0; n < rank; n++)
7ebee933	278	{
	279	if (n == 0)
	280	str = 1;
	281	else
	282	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
827aef63	283
	284	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	285
7ebee933	286	}
07ea8faa	287
af1e9051	288	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
a14c06e9	289
93830de1	290	retarray->offset = 0;
07ea8faa	291	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
a14c06e9	292
	293	if (alloc_size == 0)
	294	{
	295	/* Make sure we have a zero-sized array. */
827aef63	296	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
a14c06e9	297	return;
	298	}
	299	else
af1e9051	300	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_4));
a14c06e9	301
07ea8faa	302	}
	303	else
	304	{
07ea8faa	305	if (rank != GFC_DESCRIPTOR_RANK (retarray))
8dec97a0	306	runtime_error ("rank of return array incorrect in MINVAL intrinsic");
8dec97a0	307
c7fb575f	308	if (unlikely (compile_options.bounds_check))
8dec97a0	309	{
5d04d450	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");
8dec97a0	314	}
07ea8faa	315	}
07ea8faa	316
4ee9c684	317	for (n = 0; n < rank; n++)
	318	{
	319	count[n] = 0;
827aef63	320	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
4ee9c684	321	if (extent[n] <= 0)
7ebee933	322	return;
4ee9c684	323	}
4ee9c684	324
553877d9	325	dest = retarray->base_addr;
553877d9	326	base = array->base_addr;
4ee9c684	327
	328	while (base)
	329	{
b4cafd67	330	const GFC_REAL_4 * restrict src;
7ed8f627	331	const GFC_LOGICAL_1 * restrict msrc;
4ee9c684	332	GFC_REAL_4 result;
	333	src = base;
	334	msrc = mbase;
	335	{
	336
7ebee933	337	#if defined (GFC_REAL_4_INFINITY)
	338	result = GFC_REAL_4_INFINITY;
	339	#else
	340	result = GFC_REAL_4_HUGE;
	341	#endif
	342	#if defined (GFC_REAL_4_QUIET_NAN)
	343	int non_empty_p = 0;
	344	#endif
08e1eb56	345	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
4ee9c684	346	{
4ee9c684	347
7ebee933	348	#if defined (GFC_REAL_4_INFINITY) \|\| defined (GFC_REAL_4_QUIET_NAN)
	349	if (*msrc)
	350	{
	351	#if defined (GFC_REAL_4_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_4_QUIET_NAN)
	361	result = non_empty_p ? GFC_REAL_4_QUIET_NAN : GFC_REAL_4_HUGE;
	362	#else
	363	result = GFC_REAL_4_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;
4ee9c684	371	}
08e1eb56	372	*dest = result;
4ee9c684	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])
7ebee933	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	}
4ee9c684	405	}
	406	}
	407
4292b27d	408
	409	extern void sminval_r4 (gfc_array_r4 * const restrict,
	410	gfc_array_r4 * const restrict, const index_type * const restrict,
	411	GFC_LOGICAL_4 *);
	412	export_proto(sminval_r4);
	413
	414	void
	415	sminval_r4 (gfc_array_r4 * const restrict retarray,
	416	gfc_array_r4 * const restrict array,
	417	const index_type * const restrict pdim,
	418	GFC_LOGICAL_4 * mask)
	419	{
f955bfc4	420	index_type count[GFC_MAX_DIMENSIONS];
f955bfc4	421	index_type extent[GFC_MAX_DIMENSIONS];
f955bfc4	422	index_type dstride[GFC_MAX_DIMENSIONS];
f955bfc4	423	GFC_REAL_4 * restrict dest;
4292b27d	424	index_type rank;
4292b27d	425	index_type n;
f955bfc4	426	index_type dim;
f955bfc4	427
4292b27d	428
	429	if (*mask)
	430	{
	431	minval_r4 (retarray, array, pdim);
	432	return;
	433	}
f955bfc4	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	{
827aef63	440	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
f955bfc4	441
	442	if (extent[n] <= 0)
	443	extent[n] = 0;
	444	}
	445
	446	for (n = dim; n < rank; n++)
	447	{
f955bfc4	448	extent[n] =
7ebee933	449	GFC_DESCRIPTOR_EXTENT(array,n + 1);
f955bfc4	450
f955bfc4	451	if (extent[n] <= 0)
7ebee933	452	extent[n] = 0;
f955bfc4	453	}
4292b27d	454
553877d9	455	if (retarray->base_addr == NULL)
4292b27d	456	{
827aef63	457	size_t alloc_size, str;
f955bfc4	458
f955bfc4	459	for (n = 0; n < rank; n++)
7ebee933	460	{
	461	if (n == 0)
	462	str = 1;
	463	else
	464	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
827aef63	465
	466	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	467
7ebee933	468	}
f955bfc4	469
4292b27d	470	retarray->offset = 0;
f955bfc4	471	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
f955bfc4	472
af1e9051	473	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
f955bfc4	474
	475	if (alloc_size == 0)
	476	{
	477	/* Make sure we have a zero-sized array. */
827aef63	478	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
f955bfc4	479	return;
	480	}
	481	else
af1e9051	482	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_4));
4292b27d	483	}
	484	else
	485	{
f955bfc4	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
c7fb575f	492	if (unlikely (compile_options.bounds_check))
8dec97a0	493	{
f955bfc4	494	for (n=0; n < rank; n++)
	495	{
	496	index_type ret_extent;
4292b27d	497
827aef63	498	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
f955bfc4	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	}
8dec97a0	505	}
8dec97a0	506	}
4292b27d	507
f955bfc4	508	for (n = 0; n < rank; n++)
	509	{
	510	count[n] = 0;
827aef63	511	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
f955bfc4	512	}
f955bfc4	513
553877d9	514	dest = retarray->base_addr;
f955bfc4	515
	516	while(1)
	517	{
	518	*dest = GFC_REAL_4_HUGE;
	519	count[0]++;
	520	dest += dstride[0];
	521	n = 0;
	522	while (count[n] == extent[n])
7ebee933	523	{
f955bfc4	524	/* When we get to the end of a dimension, reset it and increment
7ebee933	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)
f955bfc4	532	return;
7ebee933	533	else
	534	{
	535	count[n]++;
	536	dest += dstride[n];
	537	}
f955bfc4	538	}
f955bfc4	539	}
4292b27d	540	}
4292b27d	541
920e54ef	542	#endif