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

/* Implementation of the FINDLOC intrinsic
   Copyright (C) 2018-2024 Free Software Foundation, Inc.
   Contributed by Thomas König <tk@tkoenig.net>

This file is part of the GNU Fortran 95 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_INTEGER_1)
extern void findloc1_i1 (gfc_array_index_type * const restrict retarray,
		         gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
			 const index_type * restrict pdim, GFC_LOGICAL_4 back);
export_proto(findloc1_i1);

extern void
findloc1_i1 (gfc_array_index_type * const restrict retarray,
	    gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
	    const index_type * 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_INTEGER_1 * restrict base;
  index_type * 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 FINDLOC 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 (index_type));
      if (alloc_size == 0)
	return;
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " FINDLOC 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", "FINDLOC");
    }

  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;
  continue_loop = 1;

  base = array->base_addr;
  while (continue_loop)
    {
      const GFC_INTEGER_1 * restrict src;
      index_type result;

      result = 0;
      if (back)
	{
	  src = base + (len - 1) * delta * 1;
	  for (n = len; n > 0; n--, src -= delta * 1)
	    {
	      if (*src == value)
		{
		  result = n;
		  break;
		}
	    }
	}
      else
	{
	  src = base;
	  for (n = 1; n <= len; n++, src += delta * 1)
	    {
	      if (*src == value)
		{
		  result = n;
		  break;
		}
	    }
	}
      *dest = result;

      count[0]++;
      base += sstride[0] * 1;
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
	{
	  count[n] = 0;
	  base -= sstride[n] * extent[n] * 1;
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n] * 1;
	      dest += dstride[n];
	    }
	}
    }
}
extern void mfindloc1_i1 (gfc_array_index_type * const restrict retarray,
		         gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
			 const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
			 GFC_LOGICAL_4 back);
export_proto(mfindloc1_i1);

extern void
mfindloc1_i1 (gfc_array_index_type * const restrict retarray,
	    gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
	    const index_type * 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 mstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_INTEGER_1 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  index_type dim;
  int mask_kind;
  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 FINDLOC 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);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  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
    internal_error (NULL, "Funny sized logical array");

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

	}

      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 (index_type));
      if (alloc_size == 0)
	return;
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " FINDLOC 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", "FINDLOC");
    }

  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;
  continue_loop = 1;

  base = array->base_addr;
  while (continue_loop)
    {
      const GFC_INTEGER_1 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      index_type result;

      result = 0;
      if (back)
	{
	  src = base + (len - 1) * delta * 1;
	  msrc = mbase + (len - 1) * mdelta; 
	  for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta)
	    {
	      if (*msrc && *src == value)
		{
		  result = n;
		  break;
		}
	    }
	}
      else
	{
	  src = base;
	  msrc = mbase;
	  for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta)
	    {
	      if (*msrc && *src == value)
		{
		  result = n;
		  break;
		}
	    }
	}
      *dest = result;

      count[0]++;
      base += sstride[0] * 1;
      mbase += mstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
	{
	  count[n] = 0;
	  base -= sstride[n] * extent[n] * 1;
	  mbase -= mstride[n] * extent[n];
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n] * 1;
	      dest += dstride[n];
	    }
	}
    }
}
extern void sfindloc1_i1 (gfc_array_index_type * const restrict retarray,
		         gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
			 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
			 GFC_LOGICAL_4 back);
export_proto(sfindloc1_i1);

extern void
sfindloc1_i1 (gfc_array_index_type * const restrict retarray,
	    gfc_array_i1 * const restrict array, GFC_INTEGER_1 value,
	    const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict  mask,
	    GFC_LOGICAL_4 back)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type dim;
  bool continue_loop;

  if (mask == NULL || *mask)
    {
      findloc1_i1 (retarray, array, value, pdim, back);
      return;
    }
    /* 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 FINDLOC 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;

  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 (index_type));
      if (alloc_size == 0)
	return;
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " FINDLOC 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", "FINDLOC");
    }

  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;
  continue_loop = 1;

  while (continue_loop)
    {
      *dest = 0;

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