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

/* Implementation of the MAXLOC intrinsic
   Copyright 2002, 2007, 2009, 2010 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>
#include <limits.h>


#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4)


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

void
maxloc1_4_i2 (gfc_array_i4 * 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_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 = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
    		   * extent[rank-1];

      retarray->base_addr = xmalloc (alloc_size);
      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"
		       " MAXLOC 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", "MAXLOC");
    }

  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_INTEGER_2 * restrict src;
      GFC_INTEGER_4 result;
      src = base;
      {

	GFC_INTEGER_2 maxval;
#if defined (GFC_INTEGER_2_INFINITY)
	maxval = -GFC_INTEGER_2_INFINITY;
#else
	maxval = (-GFC_INTEGER_2_HUGE-1);
#endif
	result = 1;
	if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

#if defined (GFC_INTEGER_2_QUIET_NAN)
		if (*src >= maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_4)n + 1;
		    break;
		  }
	      }
	    for (; n < len; n++, src += delta)
	      {
#endif
		if (*src > maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_4)n + 1;
		  }
	      }
	    
	    *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 mmaxloc1_4_i2 (gfc_array_i4 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxloc1_4_i2);

void
mmaxloc1_4_i2 (gfc_array_i4 * 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_4 * 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->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 = sizeof (GFC_INTEGER_4) * 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 = xmalloc (alloc_size);

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

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

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

	GFC_INTEGER_2 maxval;
#if defined (GFC_INTEGER_2_INFINITY)
	maxval = -GFC_INTEGER_2_INFINITY;
#else
	maxval = (-GFC_INTEGER_2_HUGE-1);
#endif
#if defined (GFC_INTEGER_2_QUIET_NAN)
	GFC_INTEGER_4 result2 = 0;
#endif
	result = 0;
	if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

		if (*msrc)
		  {
#if defined (GFC_INTEGER_2_QUIET_NAN)
		    if (!result2)
		      result2 = (GFC_INTEGER_4)n + 1;
		    if (*src >= maxval)
#endif
		      {
			maxval = *src;
			result = (GFC_INTEGER_4)n + 1;
			break;
		      }
		  }
	      }
#if defined (GFC_INTEGER_2_QUIET_NAN)
	    if (unlikely (n >= len))
	      result = result2;
	    else
#endif
	    for (; n < len; n++, src += delta, msrc += mdelta)
	      {
		if (*msrc && *src > maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_4)n + 1;
		  }
	      }
	    *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 smaxloc1_4_i2 (gfc_array_i4 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxloc1_4_i2);

void
smaxloc1_4_i2 (gfc_array_i4 * 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 dstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


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