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

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