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

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

#define HAVE_BACK_ARG 1


extern void maxloc1_4_r4 (gfc_array_i4 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
export_proto(maxloc1_4_r4);

void
maxloc1_4_r4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r4 * 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_REAL_4 * restrict base;
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

  /* Make dim zero based to avoid confusion.  */
  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_4));
      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_4 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
	  {
#if ! defined HAVE_BACK_ARG
	    for (n = 0; n < len; n++, src += delta)
	      {
#endif

#if defined (GFC_REAL_4_QUIET_NAN)
     	     for (n = 0; n < len; n++, src += delta)
	       {
		if (*src >= maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_4)n + 1;
		    break;
		  }
	      }
#else
	    n = 0;
#endif
	    for (; n < len; n++, src += delta)
	      {
		if (back ? *src >= maxval : *src > maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_4)n + 1;
		  }
	      }
	    
	    *dest = result;
	  }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
	{
	  /* When we get to the end of a dimension, reset it and increment
	     the next dimension.  */
	  count[n] = 0;
	  /* We could precalculate these products, but this is a less
	     frequently used path so probably not worth it.  */
	  base -= sstride[n] * extent[n];
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      /* Break out of the loop.  */
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void mmaxloc1_4_r4 (gfc_array_i4 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
export_proto(mmaxloc1_4_r4);

void
mmaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r4 * 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_4 * restrict dest;
  const GFC_REAL_4 * 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_4_r4 (retarray, array, pdim, back);
#else
      maxloc1_4_r4 (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_4));

    }
  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_4 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_4 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_4)n + 1;
		    if (*src >= maxval)
#endif
		      {
			maxval = *src;
			result = (GFC_INTEGER_4)n + 1;
			break;
		      }
		  }
	      }
#if defined (GFC_REAL_4_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_4)n + 1;
		    }
		}
	    else
	      for (; n < len; n++, src += delta, msrc += mdelta)
	        {
		  if (*msrc && unlikely (*src > maxval))
		    {
		      maxval = *src;
		      result = (GFC_INTEGER_4)n + 1;
		    }
	  }
	*dest = result;
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
	{
	  /* When we get to the end of a dimension, reset it and increment
	     the next dimension.  */
	  count[n] = 0;
	  /* We could precalculate these products, but this is a less
	     frequently used path so probably not worth it.  */
	  base -= sstride[n] * extent[n];
	  mbase -= mstride[n] * extent[n];
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      /* Break out of the loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void smaxloc1_4_r4 (gfc_array_i4 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
export_proto(smaxloc1_4_r4);

void
smaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r4 * 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_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      maxloc1_4_r4 (retarray, array, pdim, back);
#else
      maxloc1_4_r4 (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_4));
    }
  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
6de9cd9a	1	/* Implementation of the MAXLOC intrinsic
7adcbafe	2	Copyright (C) 2002-2022 Free Software Foundation, Inc.
6de9cd9a DN	3	Contributed by Paul Brook <paul@nowt.org>
6de9cd9a DN	4
0cd0559e	5	This file is part of the GNU Fortran runtime library (libgfortran).
6de9cd9a DN	6
6de9cd9a DN	7	Libgfortran is free software; you can redistribute it and/or
57dea9f6	8	modify it under the terms of the GNU General Public
6de9cd9a	9	License as published by the Free Software Foundation; either
748086b7	10	version 3 of the License, or (at your option) any later version.
6de9cd9a DN	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
57dea9f6	15	GNU General Public License for more details.
6de9cd9a	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/>. */
6de9cd9a	25
36ae8a61	26	#include "libgfortran.h"
64b1806b	27	#include <assert.h>
6de9cd9a	28
7d7b8bfe	29
644cb69f FXC	30	#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4)
644cb69f FXC	31
64b1806b TK	32	#define HAVE_BACK_ARG 1
64b1806b TK	33
644cb69f	34
64acfd99	35	extern void maxloc1_4_r4 (gfc_array_i4 * const restrict,
64b1806b	36	gfc_array_r4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
7f68c75f	37	export_proto(maxloc1_4_r4);
7d7b8bfe	38
6de9cd9a	39	void
64acfd99 JB	40	maxloc1_4_r4 (gfc_array_i4 * const restrict retarray,
64acfd99 JB	41	gfc_array_r4 * const restrict array,
64b1806b	42	const index_type * const restrict pdim, GFC_LOGICAL_4 back)
6de9cd9a	43	{
e33e218b TK	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];
64acfd99 JB	48	const GFC_REAL_4 * restrict base;
64acfd99 JB	49	GFC_INTEGER_4 * restrict dest;
6de9cd9a DN	50	index_type rank;
	51	index_type n;
	52	index_type len;
	53	index_type delta;
	54	index_type dim;
da96f5ab	55	int continue_loop;
6de9cd9a DN	56
6de9cd9a DN	57	/* Make dim zero based to avoid confusion. */
6de9cd9a	58	rank = GFC_DESCRIPTOR_RANK (array) - 1;
cfdf6ff6 TK	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	}
e33e218b	67
dfb55fdc	68	len = GFC_DESCRIPTOR_EXTENT(array,dim);
da96f5ab TK	69	if (len < 0)
da96f5ab TK	70	len = 0;
dfb55fdc	71	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
6de9cd9a DN	72
	73	for (n = 0; n < dim; n++)
	74	{
dfb55fdc TK	75	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
dfb55fdc TK	76	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
80ee04b9 TK	77
	78	if (extent[n] < 0)
	79	extent[n] = 0;
6de9cd9a DN	80	}
	81	for (n = dim; n < rank; n++)
	82	{
dfb55fdc TK	83	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
dfb55fdc TK	84	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
80ee04b9 TK	85
	86	if (extent[n] < 0)
	87	extent[n] = 0;
6de9cd9a DN	88	}
6de9cd9a DN	89
21d1335b	90	if (retarray->base_addr == NULL)
6c167c45	91	{
dfb55fdc	92	size_t alloc_size, str;
80ee04b9	93
6c167c45	94	for (n = 0; n < rank; n++)
80927a56 JJ	95	{
80927a56 JJ	96	if (n == 0)
dfb55fdc	97	str = 1;
80927a56 JJ	98	else
80927a56 JJ	99	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	100
	101	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	102
80927a56	103	}
6c167c45	104
efd4dc1a	105	retarray->offset = 0;
ca708a2b	106	retarray->dtype.rank = rank;
80ee04b9	107
92e6f3a4	108	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
80ee04b9	109
92e6f3a4	110	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
80ee04b9 TK	111	if (alloc_size == 0)
	112	{
	113	/* Make sure we have a zero-sized array. */
dfb55fdc	114	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9	115	return;
dfb55fdc	116
80ee04b9	117	}
6c167c45	118	}
50dd63a9 TK	119	else
50dd63a9 TK	120	{
50dd63a9	121	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8	122	runtime_error ("rank of return array incorrect in"
ccacefc7 TK	123	" MAXLOC intrinsic: is %ld, should be %ld",
	124	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	125	(long int) rank);
fd6590f8	126
9731c4a3	127	if (unlikely (compile_options.bounds_check))
16bff921 TK	128	bounds_ifunction_return ((array_t *) retarray, extent,
16bff921 TK	129	"return value", "MAXLOC");
50dd63a9 TK	130	}
50dd63a9 TK	131
6de9cd9a DN	132	for (n = 0; n < rank; n++)
	133	{
	134	count[n] = 0;
dfb55fdc	135	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
6de9cd9a	136	if (extent[n] <= 0)
facc1285	137	return;
6de9cd9a DN	138	}
6de9cd9a DN	139
21d1335b TB	140	base = array->base_addr;
21d1335b TB	141	dest = retarray->base_addr;
6de9cd9a	142
da96f5ab TK	143	continue_loop = 1;
da96f5ab TK	144	while (continue_loop)
6de9cd9a	145	{
64acfd99	146	const GFC_REAL_4 * restrict src;
6de9cd9a DN	147	GFC_INTEGER_4 result;
	148	src = base;
	149	{
	150
80927a56 JJ	151	GFC_REAL_4 maxval;
	152	#if defined (GFC_REAL_4_INFINITY)
	153	maxval = -GFC_REAL_4_INFINITY;
	154	#else
	155	maxval = -GFC_REAL_4_HUGE;
	156	#endif
	157	result = 1;
	158	if (len <= 0)
6de9cd9a DN	159	*dest = 0;
	160	else
	161	{
b573f931	162	#if ! defined HAVE_BACK_ARG
6de9cd9a DN	163	for (n = 0; n < len; n++, src += delta)
6de9cd9a DN	164	{
b573f931	165	#endif
6de9cd9a	166
80927a56	167	#if defined (GFC_REAL_4_QUIET_NAN)
b573f931 TK	168	for (n = 0; n < len; n++, src += delta)
b573f931 TK	169	{
80927a56 JJ	170	if (*src >= maxval)
	171	{
	172	maxval = *src;
	173	result = (GFC_INTEGER_4)n + 1;
	174	break;
	175	}
	176	}
b573f931 TK	177	#else
	178	n = 0;
	179	#endif
80927a56 JJ	180	for (; n < len; n++, src += delta)
80927a56 JJ	181	{
b573f931	182	if (back ? src >= maxval : src > maxval)
80927a56 JJ	183	{
	184	maxval = *src;
	185	result = (GFC_INTEGER_4)n + 1;
	186	}
	187	}
0cd0559e	188
6de9cd9a DN	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])
80927a56 JJ	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++;
80dd631f	207	if (n >= rank)
80927a56	208	{
80dd631f	209	/* Break out of the loop. */
da96f5ab TK	210	continue_loop = 0;
da96f5ab TK	211	break;
80927a56 JJ	212	}
	213	else
	214	{
	215	count[n]++;
	216	base += sstride[n];
	217	dest += dstride[n];
	218	}
	219	}
6de9cd9a DN	220	}
	221	}
	222
7d7b8bfe	223
64acfd99 JB	224	extern void mmaxloc1_4_r4 (gfc_array_i4 * const restrict,
64acfd99 JB	225	gfc_array_r4 * const restrict, const index_type * const restrict,
64b1806b	226	gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
7f68c75f	227	export_proto(mmaxloc1_4_r4);
7d7b8bfe	228
6de9cd9a	229	void
64acfd99 JB	230	mmaxloc1_4_r4 (gfc_array_i4 * const restrict retarray,
	231	gfc_array_r4 * const restrict array,
	232	const index_type * const restrict pdim,
64b1806b	233	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
6de9cd9a	234	{
e33e218b TK	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];
64acfd99 JB	240	GFC_INTEGER_4 * restrict dest;
64acfd99 JB	241	const GFC_REAL_4 * restrict base;
28dc6b33	242	const GFC_LOGICAL_1 * restrict mbase;
cfdf6ff6 TK	243	index_type rank;
cfdf6ff6 TK	244	index_type dim;
6de9cd9a DN	245	index_type n;
	246	index_type len;
	247	index_type delta;
	248	index_type mdelta;
28dc6b33	249	int mask_kind;
6de9cd9a	250
2ea47ee9 TK	251	if (mask == NULL)
	252	{
	253	#ifdef HAVE_BACK_ARG
	254	maxloc1_4_r4 (retarray, array, pdim, back);
	255	#else
	256	maxloc1_4_r4 (retarray, array, pdim);
	257	#endif
	258	return;
	259	}
	260
6de9cd9a DN	261	dim = (*pdim) - 1;
6de9cd9a DN	262	rank = GFC_DESCRIPTOR_RANK (array) - 1;
e33e218b	263
cfdf6ff6 TK	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
dfb55fdc	272	len = GFC_DESCRIPTOR_EXTENT(array,dim);
6de9cd9a DN	273	if (len <= 0)
6de9cd9a DN	274	return;
28dc6b33	275
21d1335b	276	mbase = mask->base_addr;
28dc6b33 TK	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
dfb55fdc TK	289	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
dfb55fdc TK	290	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
6de9cd9a DN	291
	292	for (n = 0; n < dim; n++)
	293	{
dfb55fdc TK	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);
80ee04b9 TK	297
	298	if (extent[n] < 0)
	299	extent[n] = 0;
	300
6de9cd9a DN	301	}
	302	for (n = dim; n < rank; n++)
	303	{
dfb55fdc TK	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);
80ee04b9 TK	307
	308	if (extent[n] < 0)
	309	extent[n] = 0;
6de9cd9a DN	310	}
6de9cd9a DN	311
21d1335b	312	if (retarray->base_addr == NULL)
50dd63a9	313	{
dfb55fdc	314	size_t alloc_size, str;
80ee04b9	315
50dd63a9	316	for (n = 0; n < rank; n++)
80927a56 JJ	317	{
	318	if (n == 0)
	319	str = 1;
	320	else
	321	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	322
	323	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	324
80927a56	325	}
50dd63a9	326
92e6f3a4	327	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
80ee04b9	328
efd4dc1a	329	retarray->offset = 0;
ca708a2b	330	retarray->dtype.rank = rank;
80ee04b9 TK	331
	332	if (alloc_size == 0)
	333	{
	334	/* Make sure we have a zero-sized array. */
dfb55fdc	335	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9 TK	336	return;
	337	}
	338	else
92e6f3a4	339	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
80ee04b9	340
50dd63a9 TK	341	}
	342	else
	343	{
50dd63a9	344	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8 TK	345	runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
fd6590f8 TK	346
9731c4a3	347	if (unlikely (compile_options.bounds_check))
fd6590f8	348	{
16bff921 TK	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");
fd6590f8	353	}
50dd63a9 TK	354	}
50dd63a9 TK	355
6de9cd9a DN	356	for (n = 0; n < rank; n++)
	357	{
	358	count[n] = 0;
dfb55fdc	359	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
6de9cd9a	360	if (extent[n] <= 0)
80927a56	361	return;
6de9cd9a DN	362	}
6de9cd9a DN	363
21d1335b TB	364	dest = retarray->base_addr;
21d1335b TB	365	base = array->base_addr;
6de9cd9a DN	366
	367	while (base)
	368	{
64acfd99	369	const GFC_REAL_4 * restrict src;
28dc6b33	370	const GFC_LOGICAL_1 * restrict msrc;
6de9cd9a DN	371	GFC_INTEGER_4 result;
	372	src = base;
	373	msrc = mbase;
	374	{
	375
80927a56 JJ	376	GFC_REAL_4 maxval;
	377	#if defined (GFC_REAL_4_INFINITY)
	378	maxval = -GFC_REAL_4_INFINITY;
	379	#else
	380	maxval = -GFC_REAL_4_HUGE;
	381	#endif
	382	#if defined (GFC_REAL_4_QUIET_NAN)
	383	GFC_INTEGER_4 result2 = 0;
	384	#endif
	385	result = 0;
036e1775	386	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
6de9cd9a	387	{
6de9cd9a	388
80927a56 JJ	389	if (*msrc)
	390	{
	391	#if defined (GFC_REAL_4_QUIET_NAN)
	392	if (!result2)
	393	result2 = (GFC_INTEGER_4)n + 1;
	394	if (*src >= maxval)
	395	#endif
	396	{
	397	maxval = *src;
	398	result = (GFC_INTEGER_4)n + 1;
	399	break;
	400	}
	401	}
	402	}
	403	#if defined (GFC_REAL_4_QUIET_NAN)
	404	if (unlikely (n >= len))
	405	result = result2;
	406	else
	407	#endif
b573f931 TK	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_4)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_4)n + 1;
	424	}
6de9cd9a	425	}
036e1775	426	*dest = result;
6de9cd9a DN	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])
80927a56 JJ	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++;
80dd631f	445	if (n >= rank)
80927a56	446	{
80dd631f	447	/* Break out of the loop. */
80927a56 JJ	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	}
6de9cd9a DN	459	}
	460	}
	461
97a62038 TK	462
	463	extern void smaxloc1_4_r4 (gfc_array_i4 * const restrict,
	464	gfc_array_r4 * const restrict, const index_type * const restrict,
64b1806b	465	GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
97a62038 TK	466	export_proto(smaxloc1_4_r4);
	467
	468	void
	469	smaxloc1_4_r4 (gfc_array_i4 * const restrict retarray,
	470	gfc_array_r4 * const restrict array,
	471	const index_type * const restrict pdim,
64b1806b	472	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
97a62038	473	{
802367d7 TK	474	index_type count[GFC_MAX_DIMENSIONS];
802367d7 TK	475	index_type extent[GFC_MAX_DIMENSIONS];
802367d7 TK	476	index_type dstride[GFC_MAX_DIMENSIONS];
802367d7 TK	477	GFC_INTEGER_4 * restrict dest;
97a62038 TK	478	index_type rank;
97a62038 TK	479	index_type n;
802367d7 TK	480	index_type dim;
802367d7 TK	481
97a62038	482
2ea47ee9	483	if (mask == NULL \|\| *mask)
97a62038	484	{
64b1806b TK	485	#ifdef HAVE_BACK_ARG
	486	maxloc1_4_r4 (retarray, array, pdim, back);
	487	#else
97a62038	488	maxloc1_4_r4 (retarray, array, pdim);
64b1806b	489	#endif
97a62038 TK	490	return;
97a62038 TK	491	}
802367d7 TK	492	/* Make dim zero based to avoid confusion. */
	493	dim = (*pdim) - 1;
	494	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	495
cfdf6ff6 TK	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
802367d7 TK	503	for (n = 0; n < dim; n++)
802367d7 TK	504	{
dfb55fdc	505	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
802367d7 TK	506
	507	if (extent[n] <= 0)
	508	extent[n] = 0;
	509	}
	510
	511	for (n = dim; n < rank; n++)
	512	{
802367d7	513	extent[n] =
80927a56	514	GFC_DESCRIPTOR_EXTENT(array,n + 1);
802367d7 TK	515
802367d7 TK	516	if (extent[n] <= 0)
80927a56	517	extent[n] = 0;
802367d7	518	}
97a62038	519
21d1335b	520	if (retarray->base_addr == NULL)
97a62038	521	{
dfb55fdc	522	size_t alloc_size, str;
802367d7 TK	523
802367d7 TK	524	for (n = 0; n < rank; n++)
80927a56 JJ	525	{
	526	if (n == 0)
	527	str = 1;
	528	else
	529	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	530
	531	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	532
80927a56	533	}
802367d7	534
97a62038	535	retarray->offset = 0;
ca708a2b	536	retarray->dtype.rank = rank;
802367d7	537
92e6f3a4	538	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
802367d7 TK	539
	540	if (alloc_size == 0)
	541	{
	542	/* Make sure we have a zero-sized array. */
dfb55fdc	543	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
802367d7 TK	544	return;
	545	}
	546	else
92e6f3a4	547	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
97a62038 TK	548	}
	549	else
	550	{
802367d7 TK	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
9731c4a3	557	if (unlikely (compile_options.bounds_check))
fd6590f8	558	{
802367d7 TK	559	for (n=0; n < rank; n++)
	560	{
	561	index_type ret_extent;
97a62038	562
dfb55fdc	563	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
802367d7 TK	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	}
fd6590f8 TK	570	}
fd6590f8 TK	571	}
97a62038	572
802367d7 TK	573	for (n = 0; n < rank; n++)
	574	{
	575	count[n] = 0;
dfb55fdc	576	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
802367d7 TK	577	}
802367d7 TK	578
21d1335b	579	dest = retarray->base_addr;
802367d7 TK	580
	581	while(1)
	582	{
	583	*dest = 0;
	584	count[0]++;
	585	dest += dstride[0];
	586	n = 0;
	587	while (count[n] == extent[n])
80927a56	588	{
802367d7	589	/* When we get to the end of a dimension, reset it and increment
80927a56 JJ	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++;
80dd631f	596	if (n >= rank)
802367d7	597	return;
80927a56 JJ	598	else
	599	{
	600	count[n]++;
	601	dest += dstride[n];
	602	}
802367d7 TK	603	}
802367d7 TK	604	}
97a62038 TK	605	}
97a62038 TK	606
644cb69f	607	#endif