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

/* Implementation of the MINVAL intrinsic
   Copyright 2002, 2007 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

This file is part of the GNU Fortran 95 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 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#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 = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  if (len < 0)
    len = 0;
  delta = array->dim[dim].stride;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

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

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

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

      alloc_size = sizeof (GFC_REAL_16) * retarray->dim[rank-1].stride
    		   * extent[rank-1];

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -1;
	  return;
	}
      else
	retarray->data = internal_malloc_size (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 (compile_options.bounds_check)
	{
	  for (n=0; n < rank; n++)
	    {
	      index_type ret_extent;

	      ret_extent = retarray->dim[n].ubound + 1
		- retarray->dim[n].lbound;
	      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] = retarray->dim[n].stride;
      if (extent[n] <= 0)
        len = 0;
    }

  base = array->data;
  dest = retarray->data;

  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_REAL_16 * restrict src;
      GFC_REAL_16 result;
      src = base;
      {

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

  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 = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  if (len <= 0)
    return;

  mbase = mask->data;

  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 = array->dim[dim].stride;
  mdelta = mask->dim[dim].stride * mask_kind;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride * mask_kind;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

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

    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      mstride[n] = mask->dim[n + 1].stride * mask_kind;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

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

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

      alloc_size = sizeof (GFC_REAL_16) * retarray->dim[rank-1].stride
    		   * 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.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -1;
	  return;
	}
      else
	retarray->data = internal_malloc_size (alloc_size);

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

      if (compile_options.bounds_check)
	{
	  for (n=0; n < rank; n++)
	    {
	      index_type ret_extent;

	      ret_extent = retarray->dim[n].ubound + 1
		- retarray->dim[n].lbound;
	      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++)
            {
              index_type mask_extent, array_extent;

	      array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
	      mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
	      if (array_extent != mask_extent)
		runtime_error ("Incorrect extent in MASK argument of"
			       " MINVAL intrinsic in dimension %ld:"
			       " is %ld, should be %ld", (long int) n + 1,
			       (long int) mask_extent, (long int) array_extent);
	    }
	}
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = retarray->dim[n].stride;
      if (extent[n] <= 0)
        return;
    }

  dest = retarray->data;
  base = array->data;

  while (base)
    {
      const GFC_REAL_16 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_REAL_16 result;
      src = base;
      msrc = mbase;
      {

  result = GFC_REAL_16_HUGE;
        if (len <= 0)
	  *dest = GFC_REAL_16_HUGE;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

  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 sstride[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++)
    {
      sstride[n] = array->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

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

  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

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

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

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

      alloc_size = sizeof (GFC_REAL_16) * retarray->dim[rank-1].stride
    		   * extent[rank-1];

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -1;
	  return;
	}
      else
	retarray->data = internal_malloc_size (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 (compile_options.bounds_check)
	{
	  for (n=0; n < rank; n++)
	    {
	      index_type ret_extent;

	      ret_extent = retarray->dim[n].ubound + 1
		- retarray->dim[n].lbound;
	      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] = retarray->dim[n].stride;
    }

  dest = retarray->data;

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