[thirdparty/gcc.git] / libgfortran / generated / findloc0_r8.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_REAL_8)
extern void findloc0_r8 (gfc_array_index_type * const restrict retarray,
       	    		gfc_array_r8 * const restrict array, GFC_REAL_8 value,
			 GFC_LOGICAL_4);
export_proto(findloc0_r8);

void
findloc0_r8 (gfc_array_index_type * const restrict retarray,
    	    gfc_array_r8 * const restrict array, GFC_REAL_8 value,
	    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;
  const GFC_REAL_8 *base;
  index_type * restrict dest;
  index_type rank;
  index_type n;
  index_type sz;

  rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype.rank = 1;
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (index_type));
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
				"FINDLOC");
    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->base_addr;

  /* Set the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;

  sz = 1;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      sz *= extent[n];
      if (extent[n] <= 0)
	return;
    }

    for (n = 0; n < rank; n++)
      count[n] = 0;

  if (back)
    {
      base = array->base_addr + (sz - 1) * 1;

      while (1)
        {
	  do
	    {
	      if (unlikely(*base == value))
	        {
		  for (n = 0; n < rank; n++)
		    dest[n * dstride] = extent[n] - count[n];

		  return;
		}
	      base -= sstride[0] * 1;
	    } while(++count[0] != extent[0]);

	  n = 0;
	  do
	    {
	      /* 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] * 1;
	      n++;
	      if (n >= rank)
	        return;
	      else
		{
		  count[n]++;
		  base -= sstride[n] * 1;
		}
	    } while (count[n] == extent[n]);      
	}
    }
  else
    {
      base = array->base_addr;
      while (1)
        {
	  do
	    {
	      if (unlikely(*base == value))
	        {
		  for (n = 0; n < rank; n++)
		    dest[n * dstride] = count[n] + 1;

		  return;
		}
	      base += sstride[0] * 1;
	    } while(++count[0] != extent[0]);

	  n = 0;
	  do
	    {
	      /* 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] * 1;
	      n++;
	      if (n >= rank)
	        return;
	      else
		{
		  count[n]++;
		  base += sstride[n] * 1;
		}
	    } while (count[n] == extent[n]);
	}
    }
  return;
}

extern void mfindloc0_r8 (gfc_array_index_type * const restrict retarray,
       	    		gfc_array_r8 * const restrict array, GFC_REAL_8 value,
			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
export_proto(mfindloc0_r8);

void
mfindloc0_r8 (gfc_array_index_type * const restrict retarray,
    	    gfc_array_r8 * const restrict array, GFC_REAL_8 value,
	    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;
  const GFC_REAL_8 *base;
  index_type * restrict dest;
  GFC_LOGICAL_1 *mbase;
  index_type rank;
  index_type n;
  int mask_kind;
  index_type sz;

  rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype.rank = 1;
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (index_type));
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
	{
	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
				  "FINDLOC");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
				"MASK argument", "FINDLOC");
	}
    }

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  mbase = mask->base_addr;

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

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->base_addr;

  /* Set the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;

  sz = 1;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      sz *= extent[n];
      if (extent[n] <= 0)
	return;
    }

    for (n = 0; n < rank; n++)
      count[n] = 0;

  if (back)
    {
      base = array->base_addr + (sz - 1) * 1;
      mbase = mbase + (sz - 1) * mask_kind;
      while (1)
        {
	  do
	    {
	      if (unlikely(*mbase && *base == value))
	        {
		  for (n = 0; n < rank; n++)
		    dest[n * dstride] = extent[n] - count[n];

		  return;
		}
	      base -= sstride[0] * 1;
	      mbase -= mstride[0];
	    } while(++count[0] != extent[0]);

	  n = 0;
	  do
	    {
	      /* 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] * 1;
	      mbase -= mstride[n] * extent[n];
	      n++;
	      if (n >= rank)
		return;
	      else
		{
		  count[n]++;
		  base -= sstride[n] * 1;
		  mbase += mstride[n];
		}
	    } while (count[n] == extent[n]);      
	}
    }
  else
    {
      base = array->base_addr;
      while (1)
        {
	  do
	    {
	      if (unlikely(*mbase && *base == value))
	        {
		  for (n = 0; n < rank; n++)
		    dest[n * dstride] = count[n] + 1;

		  return;
		}
	      base += sstride[0] * 1;
	      mbase += mstride[0];
	    } while(++count[0] != extent[0]);

	  n = 0;
	  do
	    {
	      /* 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] * 1;
	      mbase -= mstride[n] * extent[n];
	      n++;
	      if (n >= rank)
		return;
	      else
		{
		  count[n]++;
		  base += sstride[n]* 1;
		  mbase += mstride[n];
		}
	    } while (count[n] == extent[n]);
	}
    }
  return;
}

extern void sfindloc0_r8 (gfc_array_index_type * const restrict retarray,
       	    		gfc_array_r8 * const restrict array, GFC_REAL_8 value,
			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
export_proto(sfindloc0_r8);

void
sfindloc0_r8 (gfc_array_index_type * const restrict retarray,
    	    gfc_array_r8 * const restrict array, GFC_REAL_8 value,
	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
  index_type rank;
  index_type dstride;
  index_type * restrict dest;
  index_type n;

  if (mask == NULL || *mask)
    {
      findloc0_r8 (retarray, array, value, back);
      return;
    }

  rank = GFC_DESCRIPTOR_RANK (array);

  if (rank <= 0)
    internal_error (NULL, "Rank of array needs to be > 0");

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype.rank = 1;
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (index_type));
    }
  else if (unlikely (compile_options.bounds_check))
    {
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
			       "FINDLOC");
    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->base_addr;
  for (n = 0; n<rank; n++)
    dest[n * dstride] = 0 ;
}

#endif
Commit	Line	Data
01ce9e31 TK	1
01ce9e31 TK	2	/* Implementation of the FINDLOC intrinsic
8d9254fc	3	Copyright (C) 2018-2020 Free Software Foundation, Inc.
01ce9e31 TK	4	Contributed by Thomas König <tk@tkoenig.net>
	5
	6	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	7
	8	Libgfortran is free software; you can redistribute it and/or
	9	modify it under the terms of the GNU General Public
	10	License as published by the Free Software Foundation; either
	11	version 3 of the License, or (at your option) any later version.
	12
	13	Libgfortran is distributed in the hope that it will be useful,
	14	but WITHOUT ANY WARRANTY; without even the implied warranty of
	15	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	GNU General Public License for more details.
	17
	18	Under Section 7 of GPL version 3, you are granted additional
	19	permissions described in the GCC Runtime Library Exception, version
	20	3.1, as published by the Free Software Foundation.
	21
	22	You should have received a copy of the GNU General Public License and
	23	a copy of the GCC Runtime Library Exception along with this program;
	24	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	25	<http://www.gnu.org/licenses/>. */
	26
	27	#include "libgfortran.h"
	28	#include <assert.h>
	29
	30	#if defined (HAVE_GFC_REAL_8)
	31	extern void findloc0_r8 (gfc_array_index_type * const restrict retarray,
	32	gfc_array_r8 * const restrict array, GFC_REAL_8 value,
	33	GFC_LOGICAL_4);
	34	export_proto(findloc0_r8);
	35
	36	void
	37	findloc0_r8 (gfc_array_index_type * const restrict retarray,
	38	gfc_array_r8 * const restrict array, GFC_REAL_8 value,
	39	GFC_LOGICAL_4 back)
	40	{
	41	index_type count[GFC_MAX_DIMENSIONS];
	42	index_type extent[GFC_MAX_DIMENSIONS];
	43	index_type sstride[GFC_MAX_DIMENSIONS];
	44	index_type dstride;
	45	const GFC_REAL_8 *base;
	46	index_type * restrict dest;
	47	index_type rank;
	48	index_type n;
	49	index_type sz;
	50
	51	rank = GFC_DESCRIPTOR_RANK (array);
	52	if (rank <= 0)
	53	runtime_error ("Rank of array needs to be > 0");
	54
	55	if (retarray->base_addr == NULL)
	56	{
	57	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
	58	retarray->dtype.rank = 1;
	59	retarray->offset = 0;
2ea47ee9	60	retarray->base_addr = xmallocarray (rank, sizeof (index_type));
01ce9e31 TK	61	}
	62	else
	63	{
	64	if (unlikely (compile_options.bounds_check))
	65	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	66	"FINDLOC");
	67	}
	68
	69	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
	70	dest = retarray->base_addr;
	71
	72	/* Set the return value. */
	73	for (n = 0; n < rank; n++)
	74	dest[n * dstride] = 0;
	75
	76	sz = 1;
	77	for (n = 0; n < rank; n++)
	78	{
	79	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	80	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	81	sz *= extent[n];
	82	if (extent[n] <= 0)
	83	return;
	84	}
	85
	86	for (n = 0; n < rank; n++)
	87	count[n] = 0;
	88
	89	if (back)
	90	{
	91	base = array->base_addr + (sz - 1) * 1;
	92
	93	while (1)
	94	{
	95	do
	96	{
	97	if (unlikely(*base == value))
	98	{
	99	for (n = 0; n < rank; n++)
	100	dest[n * dstride] = extent[n] - count[n];
	101
	102	return;
	103	}
	104	base -= sstride[0] * 1;
	105	} while(++count[0] != extent[0]);
	106
	107	n = 0;
	108	do
	109	{
	110	/* When we get to the end of a dimension, reset it and increment
	111	the next dimension. */
	112	count[n] = 0;
	113	/* We could precalculate these products, but this is a less
	114	frequently used path so probably not worth it. */
	115	base += sstride[n] * extent[n] * 1;
	116	n++;
	117	if (n >= rank)
	118	return;
	119	else
	120	{
	121	count[n]++;
	122	base -= sstride[n] * 1;
	123	}
	124	} while (count[n] == extent[n]);
125	}
126	}
127	else
128	{
129	base = array->base_addr;
130	while (1)
131	{
132	do
133	{
134	if (unlikely(*base == value))
135	{
136	for (n = 0; n < rank; n++)
137	dest[n * dstride] = count[n] + 1;
138
139	return;
140	}
141	base += sstride[0] * 1;
142	} while(++count[0] != extent[0]);
143
144	n = 0;
145	do
146	{
147	/* When we get to the end of a dimension, reset it and increment
148	the next dimension. */
149	count[n] = 0;
150	/* We could precalculate these products, but this is a less
151	frequently used path so probably not worth it. */
152	base -= sstride[n] * extent[n] * 1;
153	n++;
154	if (n >= rank)
155	return;
156	else
157	{
158	count[n]++;
159	base += sstride[n] * 1;
160	}
161	} while (count[n] == extent[n]);
162	}
163	}
164	return;
165	}
166
167	extern void mfindloc0_r8 (gfc_array_index_type * const restrict retarray,
168	gfc_array_r8 * const restrict array, GFC_REAL_8 value,
169	gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170	export_proto(mfindloc0_r8);
171
172	void
173	mfindloc0_r8 (gfc_array_index_type * const restrict retarray,
174	gfc_array_r8 * const restrict array, GFC_REAL_8 value,
175	gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176	{
177	index_type count[GFC_MAX_DIMENSIONS];
178	index_type extent[GFC_MAX_DIMENSIONS];
179	index_type sstride[GFC_MAX_DIMENSIONS];
180	index_type mstride[GFC_MAX_DIMENSIONS];
181	index_type dstride;
182	const GFC_REAL_8 *base;
183	index_type * restrict dest;
184	GFC_LOGICAL_1 *mbase;
185	index_type rank;
186	index_type n;
187	int mask_kind;
188	index_type sz;
189
190	rank = GFC_DESCRIPTOR_RANK (array);
191	if (rank <= 0)
192	runtime_error ("Rank of array needs to be > 0");
193
194	if (retarray->base_addr == NULL)
195	{
196	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197	retarray->dtype.rank = 1;
198	retarray->offset = 0;
2ea47ee9	199	retarray->base_addr = xmallocarray (rank, sizeof (index_type));
01ce9e31 TK	200	}
	201	else
	202	{
	203	if (unlikely (compile_options.bounds_check))
	204	{
	205	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	206	"FINDLOC");
	207	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	208	"MASK argument", "FINDLOC");
	209	}
	210	}
	211
	212	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	213
	214	mbase = mask->base_addr;
	215
	216	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	217	#ifdef HAVE_GFC_LOGICAL_16
	218	\|\| mask_kind == 16
	219	#endif
	220	)
	221	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	222	else
	223	internal_error (NULL, "Funny sized logical array");
	224
	225	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
	226	dest = retarray->base_addr;
	227
	228	/* Set the return value. */
	229	for (n = 0; n < rank; n++)
	230	dest[n * dstride] = 0;
	231
	232	sz = 1;
	233	for (n = 0; n < rank; n++)
	234	{
	235	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	236	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	237	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	238	sz *= extent[n];
	239	if (extent[n] <= 0)
	240	return;
	241	}
	242
	243	for (n = 0; n < rank; n++)
	244	count[n] = 0;
	245
	246	if (back)
	247	{
	248	base = array->base_addr + (sz - 1) * 1;
	249	mbase = mbase + (sz - 1) * mask_kind;
	250	while (1)
	251	{
	252	do
	253	{
	254	if (unlikely(mbase && base == value))
	255	{
	256	for (n = 0; n < rank; n++)
	257	dest[n * dstride] = extent[n] - count[n];
	258
	259	return;
	260	}
	261	base -= sstride[0] * 1;
	262	mbase -= mstride[0];
	263	} while(++count[0] != extent[0]);
264
265	n = 0;
266	do
267	{
268	/* When we get to the end of a dimension, reset it and increment
269	the next dimension. */
270	count[n] = 0;
271	/* We could precalculate these products, but this is a less
272	frequently used path so probably not worth it. */
273	base += sstride[n] * extent[n] * 1;
274	mbase -= mstride[n] * extent[n];
275	n++;
276	if (n >= rank)
277	return;
278	else
279	{
280	count[n]++;
281	base -= sstride[n] * 1;
282	mbase += mstride[n];
283	}
284	} while (count[n] == extent[n]);
285	}
286	}
287	else
288	{
289	base = array->base_addr;
290	while (1)
291	{
292	do
293	{
294	if (unlikely(mbase && base == value))
295	{
296	for (n = 0; n < rank; n++)
297	dest[n * dstride] = count[n] + 1;
298
299	return;
300	}
301	base += sstride[0] * 1;
302	mbase += mstride[0];
303	} while(++count[0] != extent[0]);
304
305	n = 0;
306	do
307	{
308	/* When we get to the end of a dimension, reset it and increment
309	the next dimension. */
310	count[n] = 0;
311	/* We could precalculate these products, but this is a less
312	frequently used path so probably not worth it. */
313	base -= sstride[n] * extent[n] * 1;
314	mbase -= mstride[n] * extent[n];
315	n++;
316	if (n >= rank)
317	return;
318	else
319	{
320	count[n]++;
321	base += sstride[n]* 1;
322	mbase += mstride[n];
323	}
324	} while (count[n] == extent[n]);
325	}
326	}
327	return;
328	}
329
330	extern void sfindloc0_r8 (gfc_array_index_type * const restrict retarray,
331	gfc_array_r8 * const restrict array, GFC_REAL_8 value,
332	GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333	export_proto(sfindloc0_r8);
334
335	void
336	sfindloc0_r8 (gfc_array_index_type * const restrict retarray,
337	gfc_array_r8 * const restrict array, GFC_REAL_8 value,
338	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339	{
340	index_type rank;
341	index_type dstride;
342	index_type * restrict dest;
343	index_type n;
344
2ea47ee9	345	if (mask == NULL \|\| *mask)
01ce9e31 TK	346	{
	347	findloc0_r8 (retarray, array, value, back);
	348	return;
	349	}
	350
	351	rank = GFC_DESCRIPTOR_RANK (array);
	352
	353	if (rank <= 0)
	354	internal_error (NULL, "Rank of array needs to be > 0");
	355
	356	if (retarray->base_addr == NULL)
	357	{
	358	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
	359	retarray->dtype.rank = 1;
	360	retarray->offset = 0;
2ea47ee9	361	retarray->base_addr = xmallocarray (rank, sizeof (index_type));
01ce9e31 TK	362	}
	363	else if (unlikely (compile_options.bounds_check))
	364	{
	365	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	366	"FINDLOC");
	367	}
	368
	369	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
	370	dest = retarray->base_addr;
	371	for (n = 0; n<rank; n++)
	372	dest[n * dstride] = 0 ;
	373	}
	374
	375	#endif