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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2002-2018 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

This file is part of the GNU Fortran runtime library (libgfortran).

Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */

#include "libgfortran.h"


#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16)


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

void
maxloc1_16_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_16 * 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.  */
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
  dim = (*pdim) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 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_INTEGER_16 * restrict src;
      GFC_INTEGER_16 result;
      src = base;
      {

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

#if defined (GFC_INTEGER_16_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 loop.  */
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void mmaxloc1_16_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxloc1_16_i16);

void
mmaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_INTEGER_16 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type 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;


  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 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_INTEGER_16 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_16 result;
      src = base;
      msrc = mbase;
      {

	GFC_INTEGER_16 maxval;
#if defined (GFC_INTEGER_16_INFINITY)
	maxval = -GFC_INTEGER_16_INFINITY;
#else
	maxval = (-GFC_INTEGER_16_HUGE-1);
#endif
#if defined (GFC_INTEGER_16_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_INTEGER_16_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_INTEGER_16_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 loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void smaxloc1_16_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxloc1_16_i16);

void
smaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_i16 (retarray, array, pdim);
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

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