1 /* Implementation of the MINLOC intrinsic
2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
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
30 #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4)
31
32
33 extern void minloc0_4_r4 (gfc_array_i4 * const restrict retarray,
34 gfc_array_r4 * const restrict array, GFC_LOGICAL_4);
35 export_proto(minloc0_4_r4);
36
37 void
38 minloc0_4_r4 (gfc_array_i4 * const restrict retarray,
39 gfc_array_r4 * const restrict array, 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_4 *base;
46 GFC_INTEGER_4 * restrict dest;
47 index_type rank;
48 index_type n;
49
50 rank = GFC_DESCRIPTOR_RANK (array);
51 if (rank <= 0)
52 runtime_error ("Rank of array needs to be > 0");
53
54 if (retarray->base_addr == NULL)
55 {
56 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
57 retarray->dtype.rank = 1;
58 retarray->offset = 0;
59 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
60 }
61 else
62 {
63 if (unlikely (compile_options.bounds_check))
64 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
65 "MINLOC");
66 }
67
68 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
69 dest = retarray->base_addr;
70 for (n = 0; n < rank; n++)
71 {
72 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
73 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
74 count[n] = 0;
75 if (extent[n] <= 0)
76 {
77 /* Set the return value. */
78 for (n = 0; n < rank; n++)
79 dest[n * dstride] = 0;
80 return;
81 }
82 }
83
84 base = array->base_addr;
85
86 /* Initialize the return value. */
87 for (n = 0; n < rank; n++)
88 dest[n * dstride] = 1;
89 {
90
91 GFC_REAL_4 minval;
92 #if defined(GFC_REAL_4_QUIET_NAN)
93 int fast = 0;
94 #endif
95
96 #if defined(GFC_REAL_4_INFINITY)
97 minval = GFC_REAL_4_INFINITY;
98 #else
99 minval = GFC_REAL_4_HUGE;
100 #endif
101 while (base)
102 {
103 /* Implementation start. */
104
105 #if defined(GFC_REAL_4_QUIET_NAN)
106 if (unlikely (!fast))
107 {
108 do
109 {
110 if (*base <= minval)
111 {
112 fast = 1;
113 minval = *base;
114 for (n = 0; n < rank; n++)
115 dest[n * dstride] = count[n] + 1;
116 break;
117 }
118 base += sstride[0];
119 }
120 while (++count[0] != extent[0]);
121 if (likely (fast))
122 continue;
123 }
124 else
125 #endif
126 if (back)
127 do
128 {
129 if (unlikely (*base <= minval))
130 {
131 minval = *base;
132 for (n = 0; n < rank; n++)
133 dest[n * dstride] = count[n] + 1;
134 }
135 base += sstride[0];
136 }
137 while (++count[0] != extent[0]);
138 else
139 do
140 {
141 if (unlikely (*base < minval))
142 {
143 minval = *base;
144 for (n = 0; n < rank; n++)
145 dest[n * dstride] = count[n] + 1;
146 }
147 /* Implementation end. */
148 /* Advance to the next element. */
149 base += sstride[0];
150 }
151 while (++count[0] != extent[0]);
152 n = 0;
153 do
154 {
155 /* When we get to the end of a dimension, reset it and increment
156 the next dimension. */
157 count[n] = 0;
158 /* We could precalculate these products, but this is a less
159 frequently used path so probably not worth it. */
160 base -= sstride[n] * extent[n];
161 n++;
162 if (n >= rank)
163 {
164 /* Break out of the loop. */
165 base = NULL;
166 break;
167 }
168 else
169 {
170 count[n]++;
171 base += sstride[n];
172 }
173 }
174 while (count[n] == extent[n]);
175 }
176 }
177 }
178
179 extern void mminloc0_4_r4 (gfc_array_i4 * const restrict,
180 gfc_array_r4 * const restrict, gfc_array_l1 * const restrict,
181 GFC_LOGICAL_4);
182 export_proto(mminloc0_4_r4);
183
184 void
185 mminloc0_4_r4 (gfc_array_i4 * const restrict retarray,
186 gfc_array_r4 * const restrict array,
187 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
188 {
189 index_type count[GFC_MAX_DIMENSIONS];
190 index_type extent[GFC_MAX_DIMENSIONS];
191 index_type sstride[GFC_MAX_DIMENSIONS];
192 index_type mstride[GFC_MAX_DIMENSIONS];
193 index_type dstride;
194 GFC_INTEGER_4 *dest;
195 const GFC_REAL_4 *base;
196 GFC_LOGICAL_1 *mbase;
197 int rank;
198 index_type n;
199 int mask_kind;
200
201
202 if (mask == NULL)
203 {
204 minloc0_4_r4 (retarray, array, back);
205 return;
206 }
207
208 rank = GFC_DESCRIPTOR_RANK (array);
209 if (rank <= 0)
210 runtime_error ("Rank of array needs to be > 0");
211
212 if (retarray->base_addr == NULL)
213 {
214 GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
215 retarray->dtype.rank = 1;
216 retarray->offset = 0;
217 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
218 }
219 else
220 {
221 if (unlikely (compile_options.bounds_check))
222 {
223
224 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
225 "MINLOC");
226 bounds_equal_extents ((array_t *) mask, (array_t *) array,
227 "MASK argument", "MINLOC");
228 }
229 }
230
231 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
232
233 mbase = mask->base_addr;
234
235 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
236 #ifdef HAVE_GFC_LOGICAL_16
237 || mask_kind == 16
238 #endif
239 )
240 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
241 else
242 runtime_error ("Funny sized logical array");
243
244 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
245 dest = retarray->base_addr;
246 for (n = 0; n < rank; n++)
247 {
248 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
249 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
250 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
251 count[n] = 0;
252 if (extent[n] <= 0)
253 {
254 /* Set the return value. */
255 for (n = 0; n < rank; n++)
256 dest[n * dstride] = 0;
257 return;
258 }
259 }
260
261 base = array->base_addr;
262
263 /* Initialize the return value. */
264 for (n = 0; n < rank; n++)
265 dest[n * dstride] = 0;
266 {
267
268 GFC_REAL_4 minval;
269 int fast = 0;
270
271 #if defined(GFC_REAL_4_INFINITY)
272 minval = GFC_REAL_4_INFINITY;
273 #else
274 minval = GFC_REAL_4_HUGE;
275 #endif
276 while (base)
277 {
278 /* Implementation start. */
279
280 if (unlikely (!fast))
281 {
282 do
283 {
284 if (*mbase)
285 {
286 #if defined(GFC_REAL_4_QUIET_NAN)
287 if (unlikely (dest[0] == 0))
288 for (n = 0; n < rank; n++)
289 dest[n * dstride] = count[n] + 1;
290 if (*base <= minval)
291 #endif
292 {
293 fast = 1;
294 minval = *base;
295 for (n = 0; n < rank; n++)
296 dest[n * dstride] = count[n] + 1;
297 break;
298 }
299 }
300 base += sstride[0];
301 mbase += mstride[0];
302 }
303 while (++count[0] != extent[0]);
304 if (likely (fast))
305 continue;
306 }
307 else
308 if (back)
309 do
310 {
311 if (unlikely (*mbase && (*base <= minval)))
312 {
313 minval = *base;
314 for (n = 0; n < rank; n++)
315 dest[n * dstride] = count[n] + 1;
316 }
317 base += sstride[0];
318 }
319 while (++count[0] != extent[0]);
320 else
321 do
322 {
323 if (unlikely (*mbase && (*base < minval)))
324 {
325 minval = *base;
326 for (n = 0; n < rank; n++)
327 dest[n * dstride] = count[n] + 1;
328 }
329 /* Implementation end. */
330 /* Advance to the next element. */
331 base += sstride[0];
332 mbase += mstride[0];
333 }
334 while (++count[0] != extent[0]);
335 n = 0;
336 do
337 {
338 /* When we get to the end of a dimension, reset it and increment
339 the next dimension. */
340 count[n] = 0;
341 /* We could precalculate these products, but this is a less
342 frequently used path so probably not worth it. */
343 base -= sstride[n] * extent[n];
344 mbase -= mstride[n] * extent[n];
345 n++;
346 if (n >= rank)
347 {
348 /* Break out of the loop. */
349 base = NULL;
350 break;
351 }
352 else
353 {
354 count[n]++;
355 base += sstride[n];
356 mbase += mstride[n];
357 }
358 }
359 while (count[n] == extent[n]);
360 }
361 }
362 }
363
364 extern void sminloc0_4_r4 (gfc_array_i4 * const restrict,
365 gfc_array_r4 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
366 export_proto(sminloc0_4_r4);
367
368 void
369 sminloc0_4_r4 (gfc_array_i4 * const restrict retarray,
370 gfc_array_r4 * const restrict array,
371 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
372 {
373 index_type rank;
374 index_type dstride;
375 index_type n;
376 GFC_INTEGER_4 *dest;
377
378 if (mask == NULL || *mask)
379 {
380 minloc0_4_r4 (retarray, array, back);
381 return;
382 }
383
384 rank = GFC_DESCRIPTOR_RANK (array);
385
386 if (rank <= 0)
387 runtime_error ("Rank of array needs to be > 0");
388
389 if (retarray->base_addr == NULL)
390 {
391 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
392 retarray->dtype.rank = 1;
393 retarray->offset = 0;
394 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
395 }
396 else if (unlikely (compile_options.bounds_check))
397 {
398 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
399 "MINLOC");
400 }
401
402 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
403 dest = retarray->base_addr;
404 for (n = 0; n<rank; n++)
405 dest[n * dstride] = 0 ;
406 }
407 #endif