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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2017-2024 Free Software Foundation, Inc.
   Contributed by Thomas Koenig

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

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

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

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

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

#include "libgfortran.h"


#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8)

#define HAVE_BACK_ARG 1

#include <string.h>
#include <assert.h>

static inline int
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
{
  if (sizeof (GFC_UINTEGER_1) == 1)
    return memcmp (a, b, n);
  else
    return memcmp_char4 (a, b, n);
}

extern void maxloc1_8_s1 (gfc_array_i8 * const restrict, 
	gfc_array_s1 * const restrict, const index_type * const restrict , GFC_LOGICAL_4 back,
	gfc_charlen_type);
export_proto(maxloc1_8_s1);

void
maxloc1_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array, 
	const index_type * const restrict pdim, GFC_LOGICAL_4 back,
	gfc_charlen_type string_len)
{
  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_UINTEGER_1 * 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) * string_len;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
      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) * string_len;
      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_UINTEGER_1 * restrict src;
      GFC_INTEGER_8 result;
      src = base;
      {

	const GFC_UINTEGER_1 *maxval;
	maxval = NULL;
	result = 0;
	if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

		if (maxval == NULL || (back ? compare_fcn (src, maxval, string_len) >= 0 :
		   	      	      	      compare_fcn (src, maxval, string_len) > 0))
		  {
		    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_s1 (gfc_array_i8 * const restrict, 
	gfc_array_s1 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict, GFC_LOGICAL_4 back, gfc_charlen_type);
export_proto(mmaxloc1_8_s1);

void
mmaxloc1_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
	gfc_charlen_type string_len)
{
  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_UINTEGER_1 * 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_s1 (retarray, array, pdim, back, string_len);
#else
      maxloc1_8_s1 (retarray, array, pdim, string_len);
#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) * string_len;
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
      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) * string_len;
      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_UINTEGER_1 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_8 result;
      src = base;
      msrc = mbase;
      {

	const GFC_UINTEGER_1 *maxval;
	maxval = base;
	result = 0;
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

		if (*msrc)
		      {
			maxval = src;
			result = (GFC_INTEGER_8)n + 1;
			break;
		      }
	    }
	    for (; n < len; n++, src += delta, msrc += mdelta)
	      {
		if (*msrc && (back ? compare_fcn (src, maxval, string_len) >= 0 :
		   	     	     compare_fcn (src, maxval, string_len) > 0))
		  {
		    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_s1 (gfc_array_i8 * const restrict, 
	gfc_array_s1 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type);
export_proto(smaxloc1_8_s1);

void
smaxloc1_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask , GFC_LOGICAL_4 back, gfc_charlen_type string_len)
{
  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_s1 (retarray, array, pdim, back, string_len);
#else
      maxloc1_8_s1 (retarray, array, pdim, string_len);
#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) * string_len;

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  for (n = dim; n < rank; n++)
    {
      extent[n] =
	GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;

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