1 /* Implementation of the MAXLOC 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_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
31
32
33 extern void maxloc0_8_i4 (gfc_array_i8 * const restrict retarray,
34 gfc_array_i4 * const restrict array, GFC_LOGICAL_4);
35 export_proto(maxloc0_8_i4);
36
37 void
38 maxloc0_8_i4 (gfc_array_i8 * const restrict retarray,
39 gfc_array_i4 * 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_INTEGER_4 *base;
46 GFC_INTEGER_8 * 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_8));
60 }
61 else
62 {
63 if (unlikely (compile_options.bounds_check))
64 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
65 "MAXLOC");
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_INTEGER_4 maxval;
92 #if defined(GFC_INTEGER_4_QUIET_NAN)
93 int fast = 0;
94 #endif
95
96 #if defined(GFC_INTEGER_4_INFINITY)
97 maxval = -GFC_INTEGER_4_INFINITY;
98 #else
99 maxval = (-GFC_INTEGER_4_HUGE-1);
100 #endif
101 while (base)
102 {
103 /* Implementation start. */
104
105 #if defined(GFC_INTEGER_4_QUIET_NAN)
106 if (unlikely (!fast))
107 {
108 do
109 {
110 if (*base >= maxval)
111 {
112 fast = 1;
113 maxval = *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 >= maxval))
130 {
131 maxval = *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 > maxval))
142 {
143 maxval = *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 mmaxloc0_8_i4 (gfc_array_i8 * const restrict,
180 gfc_array_i4 * const restrict, gfc_array_l1 * const restrict,
181 GFC_LOGICAL_4);
182 export_proto(mmaxloc0_8_i4);
183
184 void
185 mmaxloc0_8_i4 (gfc_array_i8 * const restrict retarray,
186 gfc_array_i4 * 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_8 *dest;
195 const GFC_INTEGER_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 maxloc0_8_i4 (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_8));
218 }
219 else
220 {
221 if (unlikely (compile_options.bounds_check))
222 {
223
224 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
225 "MAXLOC");
226 bounds_equal_extents ((array_t *) mask, (array_t *) array,
227 "MASK argument", "MAXLOC");
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_INTEGER_4 maxval;
269 int fast = 0;
270
271 #if defined(GFC_INTEGER_4_INFINITY)
272 maxval = -GFC_INTEGER_4_INFINITY;
273 #else
274 maxval = (-GFC_INTEGER_4_HUGE-1);
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_INTEGER_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 >= maxval)
291 #endif
292 {
293 fast = 1;
294 maxval = *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 (*mbase && *base >= maxval)
312 {
313 maxval = *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 (*mbase && unlikely (*base > maxval))
324 {
325 maxval = *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
365 extern void smaxloc0_8_i4 (gfc_array_i8 * const restrict,
366 gfc_array_i4 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
367 export_proto(smaxloc0_8_i4);
368
369 void
370 smaxloc0_8_i4 (gfc_array_i8 * const restrict retarray,
371 gfc_array_i4 * const restrict array,
372 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
373 {
374 index_type rank;
375 index_type dstride;
376 index_type n;
377 GFC_INTEGER_8 *dest;
378
379 if (mask == NULL || *mask)
380 {
381 maxloc0_8_i4 (retarray, array, back);
382 return;
383 }
384
385 rank = GFC_DESCRIPTOR_RANK (array);
386
387 if (rank <= 0)
388 runtime_error ("Rank of array needs to be > 0");
389
390 if (retarray->base_addr == NULL)
391 {
392 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
393 retarray->dtype.rank = 1;
394 retarray->offset = 0;
395 retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
396 }
397 else if (unlikely (compile_options.bounds_check))
398 {
399 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
400 "MAXLOC");
401 }
402
403 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
404 dest = retarray->base_addr;
405 for (n = 0; n<rank; n++)
406 dest[n * dstride] = 0 ;
407 }
408 #endif