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