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

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

#define HAVE_BACK_ARG 1


extern void maxloc1_4_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
export_proto(maxloc1_4_r16);

void
maxloc1_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * 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_16 * 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)
	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_16 * restrict src;
      GFC_INTEGER_4 result;
      src = base;
      {

	GFC_REAL_16 maxval;
#if defined (GFC_REAL_16_INFINITY)
	maxval = -GFC_REAL_16_INFINITY;
#else
	maxval = -GFC_REAL_16_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_16_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_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
export_proto(mmaxloc1_4_r16);

void
mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * 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_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_4_r16 (retarray, array, pdim, back);
#else
      maxloc1_4_r16 (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)
    len = 0;

  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;

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
      if (alloc_size == 0)
	return;
    }
  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_16 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_4 result;
      src = base;
      msrc = mbase;
      {

	GFC_REAL_16 maxval;
#if defined (GFC_REAL_16_INFINITY)
	maxval = -GFC_REAL_16_INFINITY;
#else
	maxval = -GFC_REAL_16_HUGE;
#endif
#if defined (GFC_REAL_16_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_16_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_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_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_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
export_proto(smaxloc1_4_r16);

void
smaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * 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_r16 (retarray, array, pdim, back);
#else
      maxloc1_4_r16 (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];

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