1 `/* Implementation of the FINDLOC intrinsic
2 Copyright (C) 2018-2023 Free Software Foundation, Inc.
3 Contributed by Thomas König <tk@tkoenig.net>
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
29 #if defined (HAVE_'atype_name`)
32 index_type count[GFC_MAX_DIMENSIONS];
33 index_type extent[GFC_MAX_DIMENSIONS];
34 index_type sstride[GFC_MAX_DIMENSIONS];
36 const 'atype_name` *base;
37 index_type * restrict dest;
42 rank = GFC_DESCRIPTOR_RANK (array);
44 runtime_error ("Rank of array needs to be > 0");
46 if (retarray->base_addr == NULL)
48 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
49 retarray->dtype.rank = 1;
51 retarray->base_addr = xmallocarray (rank, sizeof (index_type));
55 if (unlikely (compile_options.bounds_check))
56 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
60 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
61 dest = retarray->base_addr;
63 /* Set the return value. */
64 for (n = 0; n < rank; n++)
65 dest[n * dstride] = 0;
68 for (n = 0; n < rank; n++)
70 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
71 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
77 for (n = 0; n < rank; n++)
82 base = array->base_addr + (sz - 1) * 'base_mult`'`;
88 if (unlikely('comparison`))
90 for (n = 0; n < rank; n++)
91 dest[n * dstride] = extent[n] - count[n];
95 base -= sstride[0] * 'base_mult`'`;
96 } while(++count[0] != extent[0]);
101 /* When we get to the end of a dimension, reset it and increment
102 the next dimension. */
104 /* We could precalculate these products, but this is a less
105 frequently used path so probably not worth it. */
106 base += sstride[n] * extent[n] * 'base_mult`'`;
113 base -= sstride[n] * 'base_mult`'`;
115 } while (count[n] == extent[n]);
120 base = array->base_addr;
125 if (unlikely('comparison`))
127 for (n = 0; n < rank; n++)
128 dest[n * dstride] = count[n] + 1;
132 base += sstride[0] * 'base_mult`'`;
133 } while(++count[0] != extent[0]);
138 /* When we get to the end of a dimension, reset it and increment
139 the next dimension. */
141 /* We could precalculate these products, but this is a less
142 frequently used path so probably not worth it. */
143 base -= sstride[n] * extent[n] * 'base_mult`'`;
150 base += sstride[n] * 'base_mult`'`;
152 } while (count[n] == extent[n]);
160 index_type count[GFC_MAX_DIMENSIONS];
161 index_type extent[GFC_MAX_DIMENSIONS];
162 index_type sstride[GFC_MAX_DIMENSIONS];
163 index_type mstride[GFC_MAX_DIMENSIONS];
165 const 'atype_name` *base;
166 index_type * restrict dest;
167 GFC_LOGICAL_1 *mbase;
173 rank = GFC_DESCRIPTOR_RANK (array);
175 runtime_error ("Rank of array needs to be > 0");
177 if (retarray->base_addr == NULL)
179 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
180 retarray->dtype.rank = 1;
181 retarray->offset = 0;
182 retarray->base_addr = xmallocarray (rank, sizeof (index_type));
186 if (unlikely (compile_options.bounds_check))
188 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
190 bounds_equal_extents ((array_t *) mask, (array_t *) array,
191 "MASK argument", "FINDLOC");
195 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
197 mbase = mask->base_addr;
199 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
200 #ifdef HAVE_GFC_LOGICAL_16
204 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
206 internal_error (NULL, "Funny sized logical array");
208 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
209 dest = retarray->base_addr;
211 /* Set the return value. */
212 for (n = 0; n < rank; n++)
213 dest[n * dstride] = 0;
216 for (n = 0; n < rank; n++)
218 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
219 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
220 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
226 for (n = 0; n < rank; n++)
231 base = array->base_addr + (sz - 1) * 'base_mult`'`;
232 mbase = mbase + (sz - 1) * mask_kind;
237 if (unlikely(*mbase && 'comparison`))
239 for (n = 0; n < rank; n++)
240 dest[n * dstride] = extent[n] - count[n];
244 base -= sstride[0] * 'base_mult`'`;
246 } while(++count[0] != extent[0]);
251 /* When we get to the end of a dimension, reset it and increment
252 the next dimension. */
254 /* We could precalculate these products, but this is a less
255 frequently used path so probably not worth it. */
256 base += sstride[n] * extent[n] * 'base_mult`'`;
257 mbase -= mstride[n] * extent[n];
264 base -= sstride[n] * 'base_mult`'`;
267 } while (count[n] == extent[n]);
272 base = array->base_addr;
277 if (unlikely(*mbase && 'comparison`))
279 for (n = 0; n < rank; n++)
280 dest[n * dstride] = count[n] + 1;
284 base += sstride[0] * 'base_mult`'`;
286 } while(++count[0] != extent[0]);
291 /* When we get to the end of a dimension, reset it and increment
292 the next dimension. */
294 /* We could precalculate these products, but this is a less
295 frequently used path so probably not worth it. */
296 base -= sstride[n] * extent[n] * 'base_mult`'`;
297 mbase -= mstride[n] * extent[n];
304 base += sstride[n]* 'base_mult`'`;
307 } while (count[n] == extent[n]);
317 index_type * restrict dest;
320 if (mask == NULL || *mask)
322 findloc0_'atype_code` (retarray, array, value, back'len_arg`);
326 rank = GFC_DESCRIPTOR_RANK (array);
329 internal_error (NULL, "Rank of array needs to be > 0");
331 if (retarray->base_addr == NULL)
333 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
334 retarray->dtype.rank = 1;
335 retarray->offset = 0;
336 retarray->base_addr = xmallocarray (rank, sizeof (index_type));
338 else if (unlikely (compile_options.bounds_check))
340 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
344 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
345 dest = retarray->base_addr;
346 for (n = 0; n<rank; n++)
347 dest[n * dstride] = 0 ;