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