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

/* Implementation of the MAXVAL intrinsic
   Copyright 2002, 2007, 2009 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 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_INTEGER_2) && defined (HAVE_GFC_INTEGER_2)


extern void maxval_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict);
export_proto(maxval_i2);

void
maxval_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * 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_INTEGER_2 * restrict base;
  GFC_INTEGER_2 * 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->data == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
        {
          if (n == 0)
	    str = 1;
          else
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

        }

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

      alloc_size = sizeof (GFC_INTEGER_2) * 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->data = internal_malloc_size (alloc_size);
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " MAXVAL 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", "MAXVAL");
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
        len = 0;
    }

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

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

  result = (-GFC_INTEGER_2_HUGE-1);
        if (len <= 0)
	  *dest = (-GFC_INTEGER_2_HUGE-1);
	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 mmaxval_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxval_i2);

void
mmaxval_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * 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_INTEGER_2 * restrict dest;
  const GFC_INTEGER_2 * 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->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 = 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->data == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
        {
          if (n == 0)
            str = 1;
          else
            str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

        }

      alloc_size = sizeof (GFC_INTEGER_2) * 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->data = internal_malloc_size (alloc_size);

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

      if (unlikely (compile_options.bounds_check))
	{
	  bounds_ifunction_return ((array_t *) retarray, extent,
				   "return value", "MAXVAL");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
	  			"MASK argument", "MAXVAL");
	}
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
        return;
    }

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

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

  result = (-GFC_INTEGER_2_HUGE-1);
        if (len <= 0)
	  *dest = (-GFC_INTEGER_2_HUGE-1);
	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 smaxval_i2 (gfc_array_i2 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxval_i2);

void
smaxval_i2 (gfc_array_i2 * const restrict retarray, 
	gfc_array_i2 * 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_INTEGER_2 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      maxval_i2 (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] = 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->data == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
        {
          if (n == 0)
            str = 1;
          else
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

        }

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

      alloc_size = sizeof (GFC_INTEGER_2) * 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->data = internal_malloc_size (alloc_size);
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " MAXVAL 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"
			       " MAXVAL 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->data;

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