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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2017-2018 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)
	{
	  /* 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_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;

  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) * 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;

      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_8));

    }
  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)
    {
#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];

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