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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2002-2019 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 <assert.h>


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

#define HAVE_BACK_ARG 1


extern void maxloc1_16_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
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, GFC_LOGICAL_4 back)
{
  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.rank = 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
	  {
#if ! defined HAVE_BACK_ARG
	    for (n = 0; n < len; n++, src += delta)
	      {
#endif

#if defined (GFC_INTEGER_16_QUIET_NAN)
     	     for (n = 0; n < len; n++, src += delta)
	       {
		if (*src >= maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_16)n + 1;
		    break;
		  }
	      }
#else
	    n = 0;
#endif
	    for (; n < len; n++, src += delta)
	      {
		if (back ? *src >= maxval : *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, GFC_LOGICAL_4 back);
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, GFC_LOGICAL_4 back)
{
  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;

  if (mask == NULL)
    {
#ifdef HAVE_BACK_ARG
      maxloc1_16_i16 (retarray, array, pdim, back);
#else
      maxloc1_16_i16 (retarray, array, pdim);
#endif
      return;
    }

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