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

#include <string.h>

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

extern void maxloc1_8_s4 (gfc_array_i8 * const restrict, 
	gfc_array_s4 * const restrict, const index_type * const restrict,
	gfc_charlen_type);
export_proto(maxloc1_8_s4);

void
maxloc1_8_s4 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s4 * const restrict array, 
	const index_type * const restrict pdim, 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_INTEGER_4 * 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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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_INTEGER_4 * restrict src;
      GFC_INTEGER_8 result;
      src = base;
      {

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

		if (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_s4 (gfc_array_i8 * const restrict, 
	gfc_array_s4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict, gfc_charlen_type);
export_proto(mmaxloc1_8_s4);

void
mmaxloc1_8_s4 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s4 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask, 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_INTEGER_4 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

  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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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_INTEGER_4 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_8 result;
      src = base;
      msrc = mbase;
      {

	const GFC_INTEGER_4 *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 && 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_s4 (gfc_array_i8 * const restrict, 
	gfc_array_s4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *, gfc_charlen_type);
export_proto(smaxloc1_8_s4);

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