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

/* Implementation of the MINVAL intrinsic
   Copyright (C) 2002-2017 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_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 = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_16));
      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 = 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_16));

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