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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2002-2016 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_REAL_4) && defined (HAVE_GFC_INTEGER_16)


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

void
maxloc1_16_r4 (gfc_array_i16 * const restrict retarray, 
	gfc_array_r4 * const restrict array, 
	const index_type * const restrict pdim)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_REAL_4 * restrict base;
  GFC_INTEGER_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_INTEGER_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"
		       " 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_REAL_4 * restrict src;
      GFC_INTEGER_16 result;
      src = base;
      {

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

#if defined (GFC_REAL_4_QUIET_NAN)
		if (*src >= maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_16)n + 1;
		    break;
		  }
	      }
	    for (; n < len; n++, src += delta)
	      {
#endif
		if (*src > maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_16)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_16_r4 (gfc_array_i16 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxloc1_16_r4);

void
mmaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, 
	gfc_array_r4 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_16 * restrict dest;
  const GFC_REAL_4 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len <= 0)
    return;

  mbase = mask->base_addr;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
  else
    runtime_error ("Funny sized logical array");

  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

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

    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

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

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

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

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

	}

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

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

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));

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

	GFC_REAL_4 maxval;
#if defined (GFC_REAL_4_INFINITY)
	maxval = -GFC_REAL_4_INFINITY;
#else
	maxval = -GFC_REAL_4_HUGE;
#endif
#if defined (GFC_REAL_4_QUIET_NAN)
	GFC_INTEGER_16 result2 = 0;
#endif
	result = 0;
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

		if (*msrc)
		  {
#if defined (GFC_REAL_4_QUIET_NAN)
		    if (!result2)
		      result2 = (GFC_INTEGER_16)n + 1;
		    if (*src >= maxval)
#endif
		      {
			maxval = *src;
			result = (GFC_INTEGER_16)n + 1;
			break;
		      }
		  }
	      }
#if defined (GFC_REAL_4_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_16)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_16_r4 (gfc_array_i16 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxloc1_16_r4);

void
smaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, 
	gfc_array_r4 * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_16 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      maxloc1_16_r4 (retarray, array, pdim);
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  for (n = 0; n < dim; n++)
    {
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

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

  for (n = dim; n < rank; n++)
    {
      extent[n] =
	GFC_DESCRIPTOR_EXTENT(array,n + 1);

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

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

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

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

	}

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

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

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