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