1 /* Implementation of the MAXVAL 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 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
28
29 #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8)
30
31
32 extern void maxval_r8 (gfc_array_r8 * const restrict,
33 gfc_array_r8 * const restrict, const index_type * const restrict);
34 export_proto(maxval_r8);
35
36 void
maxval_r8(gfc_array_r8 * const restrict retarray,gfc_array_r8 * const restrict array,const index_type * const restrict pdim)37 maxval_r8 (gfc_array_r8 * const restrict retarray,
38 gfc_array_r8 * const restrict array,
39 const index_type * const restrict pdim)
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[GFC_MAX_DIMENSIONS];
45 const GFC_REAL_8 * restrict base;
46 GFC_REAL_8 * restrict dest;
47 index_type rank;
48 index_type n;
49 index_type len;
50 index_type delta;
51 index_type dim;
52 int continue_loop;
53
54 #ifdef HAVE_BACK_ARG
55 assert(back == 0);
56 #endif
57
58 /* Make dim zero based to avoid confusion. */
59 rank = GFC_DESCRIPTOR_RANK (array) - 1;
60 dim = (*pdim) - 1;
61
62 if (unlikely (dim < 0 || dim > rank))
63 {
64 runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
65 "is %ld, should be between 1 and %ld",
66 (long int) dim + 1, (long int) rank + 1);
67 }
68
69 len = GFC_DESCRIPTOR_EXTENT(array,dim);
70 if (len < 0)
71 len = 0;
72 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
73
74 for (n = 0; n < dim; n++)
75 {
76 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
77 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
78
79 if (extent[n] < 0)
80 extent[n] = 0;
81 }
82 for (n = dim; n < rank; n++)
83 {
84 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
85 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
86
87 if (extent[n] < 0)
88 extent[n] = 0;
89 }
90
91 if (retarray->base_addr == NULL)
92 {
93 size_t alloc_size, str;
94
95 for (n = 0; n < rank; n++)
96 {
97 if (n == 0)
98 str = 1;
99 else
100 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
101
102 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
103
104 }
105
106 retarray->offset = 0;
107 retarray->dtype.rank = rank;
108
109 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
110
111 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_8));
112 if (alloc_size == 0)
113 {
114 /* Make sure we have a zero-sized array. */
115 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
116 return;
117
118 }
119 }
120 else
121 {
122 if (rank != GFC_DESCRIPTOR_RANK (retarray))
123 runtime_error ("rank of return array incorrect in"
124 " MAXVAL intrinsic: is %ld, should be %ld",
125 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
126 (long int) rank);
127
128 if (unlikely (compile_options.bounds_check))
129 bounds_ifunction_return ((array_t *) retarray, extent,
130 "return value", "MAXVAL");
131 }
132
133 for (n = 0; n < rank; n++)
134 {
135 count[n] = 0;
136 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
137 if (extent[n] <= 0)
138 return;
139 }
140
141 base = array->base_addr;
142 dest = retarray->base_addr;
143
144 continue_loop = 1;
145 while (continue_loop)
146 {
147 const GFC_REAL_8 * restrict src;
148 GFC_REAL_8 result;
149 src = base;
150 {
151
152 #if defined (GFC_REAL_8_INFINITY)
153 result = -GFC_REAL_8_INFINITY;
154 #else
155 result = -GFC_REAL_8_HUGE;
156 #endif
157 if (len <= 0)
158 *dest = -GFC_REAL_8_HUGE;
159 else
160 {
161 for (n = 0; n < len; n++, src += delta)
162 {
163
164 #if defined (GFC_REAL_8_QUIET_NAN)
165 if (*src >= result)
166 break;
167 }
168 if (unlikely (n >= len))
169 result = GFC_REAL_8_QUIET_NAN;
170 else for (; n < len; n++, src += delta)
171 {
172 #endif
173 if (*src > result)
174 result = *src;
175 }
176
177 *dest = result;
178 }
179 }
180 /* Advance to the next element. */
181 count[0]++;
182 base += sstride[0];
183 dest += dstride[0];
184 n = 0;
185 while (count[n] == extent[n])
186 {
187 /* When we get to the end of a dimension, reset it and increment
188 the next dimension. */
189 count[n] = 0;
190 /* We could precalculate these products, but this is a less
191 frequently used path so probably not worth it. */
192 base -= sstride[n] * extent[n];
193 dest -= dstride[n] * extent[n];
194 n++;
195 if (n >= rank)
196 {
197 /* Break out of the loop. */
198 continue_loop = 0;
199 break;
200 }
201 else
202 {
203 count[n]++;
204 base += sstride[n];
205 dest += dstride[n];
206 }
207 }
208 }
209 }
210
211
212 extern void mmaxval_r8 (gfc_array_r8 * const restrict,
213 gfc_array_r8 * const restrict, const index_type * const restrict,
214 gfc_array_l1 * const restrict);
215 export_proto(mmaxval_r8);
216
217 void
mmaxval_r8(gfc_array_r8 * const restrict retarray,gfc_array_r8 * const restrict array,const index_type * const restrict pdim,gfc_array_l1 * const restrict mask)218 mmaxval_r8 (gfc_array_r8 * const restrict retarray,
219 gfc_array_r8 * const restrict array,
220 const index_type * const restrict pdim,
221 gfc_array_l1 * const restrict mask)
222 {
223 index_type count[GFC_MAX_DIMENSIONS];
224 index_type extent[GFC_MAX_DIMENSIONS];
225 index_type sstride[GFC_MAX_DIMENSIONS];
226 index_type dstride[GFC_MAX_DIMENSIONS];
227 index_type mstride[GFC_MAX_DIMENSIONS];
228 GFC_REAL_8 * restrict dest;
229 const GFC_REAL_8 * restrict base;
230 const GFC_LOGICAL_1 * restrict mbase;
231 index_type rank;
232 index_type dim;
233 index_type n;
234 index_type len;
235 index_type delta;
236 index_type mdelta;
237 int mask_kind;
238
239 #ifdef HAVE_BACK_ARG
240 assert (back == 0);
241 #endif
242 dim = (*pdim) - 1;
243 rank = GFC_DESCRIPTOR_RANK (array) - 1;
244
245
246 if (unlikely (dim < 0 || dim > rank))
247 {
248 runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
249 "is %ld, should be between 1 and %ld",
250 (long int) dim + 1, (long int) rank + 1);
251 }
252
253 len = GFC_DESCRIPTOR_EXTENT(array,dim);
254 if (len <= 0)
255 return;
256
257 mbase = mask->base_addr;
258
259 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
260
261 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
262 #ifdef HAVE_GFC_LOGICAL_16
263 || mask_kind == 16
264 #endif
265 )
266 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
267 else
268 runtime_error ("Funny sized logical array");
269
270 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
271 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
272
273 for (n = 0; n < dim; n++)
274 {
275 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
276 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
277 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
278
279 if (extent[n] < 0)
280 extent[n] = 0;
281
282 }
283 for (n = dim; n < rank; n++)
284 {
285 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
286 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
287 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
288
289 if (extent[n] < 0)
290 extent[n] = 0;
291 }
292
293 if (retarray->base_addr == NULL)
294 {
295 size_t alloc_size, str;
296
297 for (n = 0; n < rank; n++)
298 {
299 if (n == 0)
300 str = 1;
301 else
302 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
303
304 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
305
306 }
307
308 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
309
310 retarray->offset = 0;
311 retarray->dtype.rank = rank;
312
313 if (alloc_size == 0)
314 {
315 /* Make sure we have a zero-sized array. */
316 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
317 return;
318 }
319 else
320 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_8));
321
322 }
323 else
324 {
325 if (rank != GFC_DESCRIPTOR_RANK (retarray))
326 runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
327
328 if (unlikely (compile_options.bounds_check))
329 {
330 bounds_ifunction_return ((array_t *) retarray, extent,
331 "return value", "MAXVAL");
332 bounds_equal_extents ((array_t *) mask, (array_t *) array,
333 "MASK argument", "MAXVAL");
334 }
335 }
336
337 for (n = 0; n < rank; n++)
338 {
339 count[n] = 0;
340 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
341 if (extent[n] <= 0)
342 return;
343 }
344
345 dest = retarray->base_addr;
346 base = array->base_addr;
347
348 while (base)
349 {
350 const GFC_REAL_8 * restrict src;
351 const GFC_LOGICAL_1 * restrict msrc;
352 GFC_REAL_8 result;
353 src = base;
354 msrc = mbase;
355 {
356
357 #if defined (GFC_REAL_8_INFINITY)
358 result = -GFC_REAL_8_INFINITY;
359 #else
360 result = -GFC_REAL_8_HUGE;
361 #endif
362 #if defined (GFC_REAL_8_QUIET_NAN)
363 int non_empty_p = 0;
364 #endif
365 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
366 {
367
368 #if defined (GFC_REAL_8_INFINITY) || defined (GFC_REAL_8_QUIET_NAN)
369 if (*msrc)
370 {
371 #if defined (GFC_REAL_8_QUIET_NAN)
372 non_empty_p = 1;
373 if (*src >= result)
374 #endif
375 break;
376 }
377 }
378 if (unlikely (n >= len))
379 {
380 #if defined (GFC_REAL_8_QUIET_NAN)
381 result = non_empty_p ? GFC_REAL_8_QUIET_NAN : -GFC_REAL_8_HUGE;
382 #else
383 result = -GFC_REAL_8_HUGE;
384 #endif
385 }
386 else for (; n < len; n++, src += delta, msrc += mdelta)
387 {
388 #endif
389 if (*msrc && *src > result)
390 result = *src;
391 }
392 *dest = result;
393 }
394 /* Advance to the next element. */
395 count[0]++;
396 base += sstride[0];
397 mbase += mstride[0];
398 dest += dstride[0];
399 n = 0;
400 while (count[n] == extent[n])
401 {
402 /* When we get to the end of a dimension, reset it and increment
403 the next dimension. */
404 count[n] = 0;
405 /* We could precalculate these products, but this is a less
406 frequently used path so probably not worth it. */
407 base -= sstride[n] * extent[n];
408 mbase -= mstride[n] * extent[n];
409 dest -= dstride[n] * extent[n];
410 n++;
411 if (n >= rank)
412 {
413 /* Break out of the loop. */
414 base = NULL;
415 break;
416 }
417 else
418 {
419 count[n]++;
420 base += sstride[n];
421 mbase += mstride[n];
422 dest += dstride[n];
423 }
424 }
425 }
426 }
427
428
429 extern void smaxval_r8 (gfc_array_r8 * const restrict,
430 gfc_array_r8 * const restrict, const index_type * const restrict,
431 GFC_LOGICAL_4 *);
432 export_proto(smaxval_r8);
433
434 void
smaxval_r8(gfc_array_r8 * const restrict retarray,gfc_array_r8 * const restrict array,const index_type * const restrict pdim,GFC_LOGICAL_4 * mask)435 smaxval_r8 (gfc_array_r8 * const restrict retarray,
436 gfc_array_r8 * const restrict array,
437 const index_type * const restrict pdim,
438 GFC_LOGICAL_4 * mask)
439 {
440 index_type count[GFC_MAX_DIMENSIONS];
441 index_type extent[GFC_MAX_DIMENSIONS];
442 index_type dstride[GFC_MAX_DIMENSIONS];
443 GFC_REAL_8 * restrict dest;
444 index_type rank;
445 index_type n;
446 index_type dim;
447
448
449 if (*mask)
450 {
451 #ifdef HAVE_BACK_ARG
452 maxval_r8 (retarray, array, pdim, back);
453 #else
454 maxval_r8 (retarray, array, pdim);
455 #endif
456 return;
457 }
458 /* Make dim zero based to avoid confusion. */
459 dim = (*pdim) - 1;
460 rank = GFC_DESCRIPTOR_RANK (array) - 1;
461
462 if (unlikely (dim < 0 || dim > rank))
463 {
464 runtime_error ("Dim argument incorrect in MAXVAL intrinsic: "
465 "is %ld, should be between 1 and %ld",
466 (long int) dim + 1, (long int) rank + 1);
467 }
468
469 for (n = 0; n < dim; n++)
470 {
471 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
472
473 if (extent[n] <= 0)
474 extent[n] = 0;
475 }
476
477 for (n = dim; n < rank; n++)
478 {
479 extent[n] =
480 GFC_DESCRIPTOR_EXTENT(array,n + 1);
481
482 if (extent[n] <= 0)
483 extent[n] = 0;
484 }
485
486 if (retarray->base_addr == NULL)
487 {
488 size_t alloc_size, str;
489
490 for (n = 0; n < rank; n++)
491 {
492 if (n == 0)
493 str = 1;
494 else
495 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
496
497 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
498
499 }
500
501 retarray->offset = 0;
502 retarray->dtype.rank = rank;
503
504 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
505
506 if (alloc_size == 0)
507 {
508 /* Make sure we have a zero-sized array. */
509 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
510 return;
511 }
512 else
513 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_8));
514 }
515 else
516 {
517 if (rank != GFC_DESCRIPTOR_RANK (retarray))
518 runtime_error ("rank of return array incorrect in"
519 " MAXVAL intrinsic: is %ld, should be %ld",
520 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
521 (long int) rank);
522
523 if (unlikely (compile_options.bounds_check))
524 {
525 for (n=0; n < rank; n++)
526 {
527 index_type ret_extent;
528
529 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
530 if (extent[n] != ret_extent)
531 runtime_error ("Incorrect extent in return value of"
532 " MAXVAL intrinsic in dimension %ld:"
533 " is %ld, should be %ld", (long int) n + 1,
534 (long int) ret_extent, (long int) extent[n]);
535 }
536 }
537 }
538
539 for (n = 0; n < rank; n++)
540 {
541 count[n] = 0;
542 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
543 }
544
545 dest = retarray->base_addr;
546
547 while(1)
548 {
549 *dest = -GFC_REAL_8_HUGE;
550 count[0]++;
551 dest += dstride[0];
552 n = 0;
553 while (count[n] == extent[n])
554 {
555 /* When we get to the end of a dimension, reset it and increment
556 the next dimension. */
557 count[n] = 0;
558 /* We could precalculate these products, but this is a less
559 frequently used path so probably not worth it. */
560 dest -= dstride[n] * extent[n];
561 n++;
562 if (n >= rank)
563 return;
564 else
565 {
566 count[n]++;
567 dest += dstride[n];
568 }
569 }
570 }
571 }
572
573 #endif
574