[thirdparty/gcc.git] / libgfortran / generated / maxloc1_8_r17.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_17) && defined (HAVE_GFC_INTEGER_8)

#define HAVE_BACK_ARG 1


extern void maxloc1_8_r17 (gfc_array_i8 * const restrict, 
	gfc_array_r17 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
export_proto(maxloc1_8_r17);

void
maxloc1_8_r17 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r17 * 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_17 * restrict base;
  GFC_INTEGER_8 * 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_8));
      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_17 * restrict src;
      GFC_INTEGER_8 result;
      src = base;
      {

	GFC_REAL_17 maxval;
#if defined (GFC_REAL_17_INFINITY)
	maxval = -GFC_REAL_17_INFINITY;
#else
	maxval = -GFC_REAL_17_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_17_QUIET_NAN)
     	     for (n = 0; n < len; n++, src += delta)
	       {
		if (*src >= maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_8)n + 1;
		    break;
		  }
	      }
#else
	    n = 0;
#endif
	    for (; n < len; n++, src += delta)
	      {
		if (back ? *src >= maxval : *src > maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_8)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_8_r17 (gfc_array_i8 * const restrict, 
	gfc_array_r17 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
export_proto(mmaxloc1_8_r17);

void
mmaxloc1_8_r17 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r17 * 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_8 * restrict dest;
  const GFC_REAL_17 * 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_8_r17 (retarray, array, pdim, back);
#else
      maxloc1_8_r17 (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_8));
      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_17 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_8 result;
      src = base;
      msrc = mbase;
      {

	GFC_REAL_17 maxval;
#if defined (GFC_REAL_17_INFINITY)
	maxval = -GFC_REAL_17_INFINITY;
#else
	maxval = -GFC_REAL_17_HUGE;
#endif
#if defined (GFC_REAL_17_QUIET_NAN)
	GFC_INTEGER_8 result2 = 0;
#endif
	result = 0;
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

		if (*msrc)
		  {
#if defined (GFC_REAL_17_QUIET_NAN)
		    if (!result2)
		      result2 = (GFC_INTEGER_8)n + 1;
		    if (*src >= maxval)
#endif
		      {
			maxval = *src;
			result = (GFC_INTEGER_8)n + 1;
			break;
		      }
		  }
	      }
#if defined (GFC_REAL_17_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_8)n + 1;
		    }
		}
	    else
	      for (; n < len; n++, src += delta, msrc += mdelta)
	        {
		  if (*msrc && unlikely (*src > maxval))
		    {
		      maxval = *src;
		      result = (GFC_INTEGER_8)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_8_r17 (gfc_array_i8 * const restrict, 
	gfc_array_r17 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
export_proto(smaxloc1_8_r17);

void
smaxloc1_8_r17 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r17 * 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_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      maxloc1_8_r17 (retarray, array, pdim, back);
#else
      maxloc1_8_r17 (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_8));
      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
49ad4d2c	1	/* Implementation of the MAXLOC intrinsic
a945c346	2	Copyright (C) 2002-2024 Free Software Foundation, Inc.
49ad4d2c TK	3	Contributed by Paul Brook <paul@nowt.org>
	4
	5	This file is part of the GNU Fortran runtime library (libgfortran).
	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
	10	version 3 of the License, or (at your option) any later version.
	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
	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/>. */
	25
	26	#include "libgfortran.h"
	27	#include <assert.h>
	28
	29
	30	#if defined (HAVE_GFC_REAL_17) && defined (HAVE_GFC_INTEGER_8)
	31
	32	#define HAVE_BACK_ARG 1
	33
	34
	35	extern void maxloc1_8_r17 (gfc_array_i8 * const restrict,
	36	gfc_array_r17 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
	37	export_proto(maxloc1_8_r17);
	38
	39	void
	40	maxloc1_8_r17 (gfc_array_i8 * const restrict retarray,
	41	gfc_array_r17 * const restrict array,
	42	const index_type * const restrict pdim, GFC_LOGICAL_4 back)
	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];
	48	const GFC_REAL_17 * restrict base;
	49	GFC_INTEGER_8 * restrict dest;
	50	index_type rank;
	51	index_type n;
	52	index_type len;
	53	index_type delta;
	54	index_type dim;
	55	int continue_loop;
	56
	57	/* Make dim zero based to avoid confusion. */
	58	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	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	}
67
68	len = GFC_DESCRIPTOR_EXTENT(array,dim);
69	if (len < 0)
70	len = 0;
71	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
72
73	for (n = 0; n < dim; n++)
74	{
75	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
76	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
77
78	if (extent[n] < 0)
79	extent[n] = 0;
80	}
81	for (n = dim; n < rank; n++)
82	{
83	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
84	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
85
86	if (extent[n] < 0)
87	extent[n] = 0;
88	}
89
90	if (retarray->base_addr == NULL)
91	{
92	size_t alloc_size, str;
93
94	for (n = 0; n < rank; n++)
95	{
96	if (n == 0)
97	str = 1;
98	else
99	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
100
101	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
102
103	}
104
105	retarray->offset = 0;
106	retarray->dtype.rank = rank;
107
108	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
109
110	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
111	if (alloc_size == 0)
62715bf8	112	return;
49ad4d2c TK	113	}
	114	else
	115	{
	116	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	117	runtime_error ("rank of return array incorrect in"
	118	" MAXLOC intrinsic: is %ld, should be %ld",
	119	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	120	(long int) rank);
	121
	122	if (unlikely (compile_options.bounds_check))
	123	bounds_ifunction_return ((array_t *) retarray, extent,
	124	"return value", "MAXLOC");
	125	}
	126
	127	for (n = 0; n < rank; n++)
	128	{
	129	count[n] = 0;
	130	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	131	if (extent[n] <= 0)
	132	return;
	133	}
	134
	135	base = array->base_addr;
	136	dest = retarray->base_addr;
	137
	138	continue_loop = 1;
	139	while (continue_loop)
	140	{
	141	const GFC_REAL_17 * restrict src;
	142	GFC_INTEGER_8 result;
	143	src = base;
	144	{
	145
	146	GFC_REAL_17 maxval;
	147	#if defined (GFC_REAL_17_INFINITY)
	148	maxval = -GFC_REAL_17_INFINITY;
	149	#else
	150	maxval = -GFC_REAL_17_HUGE;
	151	#endif
	152	result = 1;
	153	if (len <= 0)
	154	*dest = 0;
	155	else
	156	{
	157	#if ! defined HAVE_BACK_ARG
	158	for (n = 0; n < len; n++, src += delta)
	159	{
	160	#endif
	161
	162	#if defined (GFC_REAL_17_QUIET_NAN)
	163	for (n = 0; n < len; n++, src += delta)
	164	{
	165	if (*src >= maxval)
	166	{
	167	maxval = *src;
	168	result = (GFC_INTEGER_8)n + 1;
	169	break;
	170	}
	171	}
	172	#else
	173	n = 0;
	174	#endif
	175	for (; n < len; n++, src += delta)
	176	{
177	if (back ? src >= maxval : src > maxval)
178	{
179	maxval = *src;
180	result = (GFC_INTEGER_8)n + 1;
181	}
182	}
183
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])
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++;
202	if (n >= rank)
203	{
204	/* Break out of the loop. */
205	continue_loop = 0;
206	break;
207	}
208	else
209	{
210	count[n]++;
211	base += sstride[n];
212	dest += dstride[n];
213	}
214	}
215	}
216	}
217
218
219	extern void mmaxloc1_8_r17 (gfc_array_i8 * const restrict,
220	gfc_array_r17 * const restrict, const index_type * const restrict,
221	gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
222	export_proto(mmaxloc1_8_r17);
223
224	void
225	mmaxloc1_8_r17 (gfc_array_i8 * const restrict retarray,
226	gfc_array_r17 * const restrict array,
227	const index_type * const restrict pdim,
228	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
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];
235	GFC_INTEGER_8 * restrict dest;
236	const GFC_REAL_17 * restrict base;
237	const GFC_LOGICAL_1 * restrict mbase;
238	index_type rank;
239	index_type dim;
240	index_type n;
241	index_type len;
242	index_type delta;
243	index_type mdelta;
244	int mask_kind;
245
246	if (mask == NULL)
247	{
248	#ifdef HAVE_BACK_ARG
249	maxloc1_8_r17 (retarray, array, pdim, back);
250	#else
251	maxloc1_8_r17 (retarray, array, pdim);
252	#endif
253	return;
254	}
255
256	dim = (*pdim) - 1;
257	rank = GFC_DESCRIPTOR_RANK (array) - 1;
258
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
267	len = GFC_DESCRIPTOR_EXTENT(array,dim);
85a96881 MM	268	if (len < 0)
85a96881 MM	269	len = 0;
49ad4d2c TK	270
	271	mbase = mask->base_addr;
	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
	284	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
	285	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	286
	287	for (n = 0; n < dim; n++)
	288	{
	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);
	292
	293	if (extent[n] < 0)
	294	extent[n] = 0;
	295
	296	}
	297	for (n = dim; n < rank; n++)
	298	{
	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);
	302
	303	if (extent[n] < 0)
	304	extent[n] = 0;
	305	}
	306
	307	if (retarray->base_addr == NULL)
	308	{
	309	size_t alloc_size, str;
	310
	311	for (n = 0; n < rank; n++)
	312	{
	313	if (n == 0)
	314	str = 1;
	315	else
	316	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	317
	318	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	319
	320	}
	321
	322	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
	323
	324	retarray->offset = 0;
	325	retarray->dtype.rank = rank;
	326
d56bf419	327	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
49ad4d2c	328	if (alloc_size == 0)
62715bf8	329	return;
49ad4d2c TK	330	}
	331	else
	332	{
	333	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	334	runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
	335
	336	if (unlikely (compile_options.bounds_check))
	337	{
	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");
	342	}
	343	}
	344
	345	for (n = 0; n < rank; n++)
	346	{
	347	count[n] = 0;
	348	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	349	if (extent[n] <= 0)
	350	return;
	351	}
	352
	353	dest = retarray->base_addr;
	354	base = array->base_addr;
	355
	356	while (base)
	357	{
	358	const GFC_REAL_17 * restrict src;
	359	const GFC_LOGICAL_1 * restrict msrc;
	360	GFC_INTEGER_8 result;
	361	src = base;
	362	msrc = mbase;
	363	{
	364
	365	GFC_REAL_17 maxval;
	366	#if defined (GFC_REAL_17_INFINITY)
	367	maxval = -GFC_REAL_17_INFINITY;
	368	#else
	369	maxval = -GFC_REAL_17_HUGE;
	370	#endif
	371	#if defined (GFC_REAL_17_QUIET_NAN)
	372	GFC_INTEGER_8 result2 = 0;
	373	#endif
	374	result = 0;
	375	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	376	{
	377
	378	if (*msrc)
	379	{
	380	#if defined (GFC_REAL_17_QUIET_NAN)
	381	if (!result2)
	382	result2 = (GFC_INTEGER_8)n + 1;
	383	if (*src >= maxval)
	384	#endif
	385	{
	386	maxval = *src;
	387	result = (GFC_INTEGER_8)n + 1;
	388	break;
	389	}
	390	}
	391	}
	392	#if defined (GFC_REAL_17_QUIET_NAN)
	393	if (unlikely (n >= len))
394	result = result2;
395	else
396	#endif
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_8)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_8)n + 1;
413	}
414	}
415	*dest = result;
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])
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++;
434	if (n >= rank)
435	{
436	/* Break out of the loop. */
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	}
448	}
449	}
450
451
452	extern void smaxloc1_8_r17 (gfc_array_i8 * const restrict,
453	gfc_array_r17 * const restrict, const index_type * const restrict,
454	GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
455	export_proto(smaxloc1_8_r17);
456
457	void
458	smaxloc1_8_r17 (gfc_array_i8 * const restrict retarray,
459	gfc_array_r17 * const restrict array,
460	const index_type * const restrict pdim,
461	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
462	{
463	index_type count[GFC_MAX_DIMENSIONS];
464	index_type extent[GFC_MAX_DIMENSIONS];
465	index_type dstride[GFC_MAX_DIMENSIONS];
466	GFC_INTEGER_8 * restrict dest;
467	index_type rank;
468	index_type n;
469	index_type dim;
470
471
472	if (mask == NULL \|\| *mask)
473	{
474	#ifdef HAVE_BACK_ARG
475	maxloc1_8_r17 (retarray, array, pdim, back);
476	#else
477	maxloc1_8_r17 (retarray, array, pdim);
478	#endif
479	return;
480	}
481	/* Make dim zero based to avoid confusion. */
482	dim = (*pdim) - 1;
483	rank = GFC_DESCRIPTOR_RANK (array) - 1;
484
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
492	for (n = 0; n < dim; n++)
493	{
494	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
495
496	if (extent[n] <= 0)
497	extent[n] = 0;
498	}
499
500	for (n = dim; n < rank; n++)
501	{
502	extent[n] =
503	GFC_DESCRIPTOR_EXTENT(array,n + 1);
504
505	if (extent[n] <= 0)
506	extent[n] = 0;
507	}
508
509	if (retarray->base_addr == NULL)
510	{
511	size_t alloc_size, str;
512
513	for (n = 0; n < rank; n++)
514	{
515	if (n == 0)
516	str = 1;
517	else
518	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
519
520	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
521
522	}
523
524	retarray->offset = 0;
525	retarray->dtype.rank = rank;
526
527	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
528
d56bf419	529	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
49ad4d2c	530	if (alloc_size == 0)
62715bf8	531	return;
49ad4d2c TK	532	}
	533	else
	534	{
	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
	541	if (unlikely (compile_options.bounds_check))
	542	{
	543	for (n=0; n < rank; n++)
	544	{
	545	index_type ret_extent;
	546
	547	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	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	}
	554	}
	555	}
	556
	557	for (n = 0; n < rank; n++)
	558	{
	559	count[n] = 0;
	560	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	561	}
	562
	563	dest = retarray->base_addr;
	564
	565	while(1)
	566	{
	567	*dest = 0;
	568	count[0]++;
	569	dest += dstride[0];
	570	n = 0;
	571	while (count[n] == extent[n])
	572	{
	573	/* When we get to the end of a dimension, reset it and increment
	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++;
	580	if (n >= rank)
	581	return;
	582	else
	583	{
	584	count[n]++;
	585	dest += dstride[n];
	586	}
	587	}
	588	}
	589	}
	590
	591	#endif