1760c2415Smrg /* Implementation of the MINLOC intrinsic
2*0bfacb9bSmrg Copyright (C) 2002-2020 Free Software Foundation, Inc.
3760c2415Smrg Contributed by Paul Brook <paul@nowt.org>
4760c2415Smrg
5760c2415Smrg This file is part of the GNU Fortran runtime library (libgfortran).
6760c2415Smrg
7760c2415Smrg Libgfortran is free software; you can redistribute it and/or
8760c2415Smrg modify it under the terms of the GNU General Public
9760c2415Smrg License as published by the Free Software Foundation; either
10760c2415Smrg version 3 of the License, or (at your option) any later version.
11760c2415Smrg
12760c2415Smrg Libgfortran is distributed in the hope that it will be useful,
13760c2415Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
14760c2415Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15760c2415Smrg GNU General Public License for more details.
16760c2415Smrg
17760c2415Smrg Under Section 7 of GPL version 3, you are granted additional
18760c2415Smrg permissions described in the GCC Runtime Library Exception, version
19760c2415Smrg 3.1, as published by the Free Software Foundation.
20760c2415Smrg
21760c2415Smrg You should have received a copy of the GNU General Public License and
22760c2415Smrg a copy of the GCC Runtime Library Exception along with this program;
23760c2415Smrg see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24760c2415Smrg <http://www.gnu.org/licenses/>. */
25760c2415Smrg
26760c2415Smrg #include "libgfortran.h"
27760c2415Smrg #include <assert.h>
28760c2415Smrg
29760c2415Smrg
30760c2415Smrg #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4)
31760c2415Smrg
32760c2415Smrg #define HAVE_BACK_ARG 1
33760c2415Smrg
34760c2415Smrg
35760c2415Smrg extern void minloc1_4_r10 (gfc_array_i4 * const restrict,
36760c2415Smrg gfc_array_r10 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
37760c2415Smrg export_proto(minloc1_4_r10);
38760c2415Smrg
39760c2415Smrg void
minloc1_4_r10(gfc_array_i4 * const restrict retarray,gfc_array_r10 * const restrict array,const index_type * const restrict pdim,GFC_LOGICAL_4 back)40760c2415Smrg minloc1_4_r10 (gfc_array_i4 * const restrict retarray,
41760c2415Smrg gfc_array_r10 * const restrict array,
42760c2415Smrg const index_type * const restrict pdim, GFC_LOGICAL_4 back)
43760c2415Smrg {
44760c2415Smrg index_type count[GFC_MAX_DIMENSIONS];
45760c2415Smrg index_type extent[GFC_MAX_DIMENSIONS];
46760c2415Smrg index_type sstride[GFC_MAX_DIMENSIONS];
47760c2415Smrg index_type dstride[GFC_MAX_DIMENSIONS];
48760c2415Smrg const GFC_REAL_10 * restrict base;
49760c2415Smrg GFC_INTEGER_4 * restrict dest;
50760c2415Smrg index_type rank;
51760c2415Smrg index_type n;
52760c2415Smrg index_type len;
53760c2415Smrg index_type delta;
54760c2415Smrg index_type dim;
55760c2415Smrg int continue_loop;
56760c2415Smrg
57760c2415Smrg /* Make dim zero based to avoid confusion. */
58760c2415Smrg rank = GFC_DESCRIPTOR_RANK (array) - 1;
59760c2415Smrg dim = (*pdim) - 1;
60760c2415Smrg
61760c2415Smrg if (unlikely (dim < 0 || dim > rank))
62760c2415Smrg {
63760c2415Smrg runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
64760c2415Smrg "is %ld, should be between 1 and %ld",
65760c2415Smrg (long int) dim + 1, (long int) rank + 1);
66760c2415Smrg }
67760c2415Smrg
68760c2415Smrg len = GFC_DESCRIPTOR_EXTENT(array,dim);
69760c2415Smrg if (len < 0)
70760c2415Smrg len = 0;
71760c2415Smrg delta = GFC_DESCRIPTOR_STRIDE(array,dim);
72760c2415Smrg
73760c2415Smrg for (n = 0; n < dim; n++)
74760c2415Smrg {
75760c2415Smrg sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
76760c2415Smrg extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
77760c2415Smrg
78760c2415Smrg if (extent[n] < 0)
79760c2415Smrg extent[n] = 0;
80760c2415Smrg }
81760c2415Smrg for (n = dim; n < rank; n++)
82760c2415Smrg {
83760c2415Smrg sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
84760c2415Smrg extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
85760c2415Smrg
86760c2415Smrg if (extent[n] < 0)
87760c2415Smrg extent[n] = 0;
88760c2415Smrg }
89760c2415Smrg
90760c2415Smrg if (retarray->base_addr == NULL)
91760c2415Smrg {
92760c2415Smrg size_t alloc_size, str;
93760c2415Smrg
94760c2415Smrg for (n = 0; n < rank; n++)
95760c2415Smrg {
96760c2415Smrg if (n == 0)
97760c2415Smrg str = 1;
98760c2415Smrg else
99760c2415Smrg str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
100760c2415Smrg
101760c2415Smrg GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
102760c2415Smrg
103760c2415Smrg }
104760c2415Smrg
105760c2415Smrg retarray->offset = 0;
106760c2415Smrg retarray->dtype.rank = rank;
107760c2415Smrg
108760c2415Smrg alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
109760c2415Smrg
110760c2415Smrg retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
111760c2415Smrg if (alloc_size == 0)
112760c2415Smrg {
113760c2415Smrg /* Make sure we have a zero-sized array. */
114760c2415Smrg GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
115760c2415Smrg return;
116760c2415Smrg
117760c2415Smrg }
118760c2415Smrg }
119760c2415Smrg else
120760c2415Smrg {
121760c2415Smrg if (rank != GFC_DESCRIPTOR_RANK (retarray))
122760c2415Smrg runtime_error ("rank of return array incorrect in"
123760c2415Smrg " MINLOC intrinsic: is %ld, should be %ld",
124760c2415Smrg (long int) (GFC_DESCRIPTOR_RANK (retarray)),
125760c2415Smrg (long int) rank);
126760c2415Smrg
127760c2415Smrg if (unlikely (compile_options.bounds_check))
128760c2415Smrg bounds_ifunction_return ((array_t *) retarray, extent,
129760c2415Smrg "return value", "MINLOC");
130760c2415Smrg }
131760c2415Smrg
132760c2415Smrg for (n = 0; n < rank; n++)
133760c2415Smrg {
134760c2415Smrg count[n] = 0;
135760c2415Smrg dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
136760c2415Smrg if (extent[n] <= 0)
137760c2415Smrg return;
138760c2415Smrg }
139760c2415Smrg
140760c2415Smrg base = array->base_addr;
141760c2415Smrg dest = retarray->base_addr;
142760c2415Smrg
143760c2415Smrg continue_loop = 1;
144760c2415Smrg while (continue_loop)
145760c2415Smrg {
146760c2415Smrg const GFC_REAL_10 * restrict src;
147760c2415Smrg GFC_INTEGER_4 result;
148760c2415Smrg src = base;
149760c2415Smrg {
150760c2415Smrg
151760c2415Smrg GFC_REAL_10 minval;
152760c2415Smrg #if defined (GFC_REAL_10_INFINITY)
153760c2415Smrg minval = GFC_REAL_10_INFINITY;
154760c2415Smrg #else
155760c2415Smrg minval = GFC_REAL_10_HUGE;
156760c2415Smrg #endif
157760c2415Smrg result = 1;
158760c2415Smrg if (len <= 0)
159760c2415Smrg *dest = 0;
160760c2415Smrg else
161760c2415Smrg {
162760c2415Smrg #if ! defined HAVE_BACK_ARG
163760c2415Smrg for (n = 0; n < len; n++, src += delta)
164760c2415Smrg {
165760c2415Smrg #endif
166760c2415Smrg
167760c2415Smrg #if defined (GFC_REAL_10_QUIET_NAN)
168760c2415Smrg for (n = 0; n < len; n++, src += delta)
169760c2415Smrg {
170760c2415Smrg if (*src <= minval)
171760c2415Smrg {
172760c2415Smrg minval = *src;
173760c2415Smrg result = (GFC_INTEGER_4)n + 1;
174760c2415Smrg break;
175760c2415Smrg }
176760c2415Smrg }
177760c2415Smrg #else
178760c2415Smrg n = 0;
179760c2415Smrg #endif
180760c2415Smrg if (back)
181760c2415Smrg for (; n < len; n++, src += delta)
182760c2415Smrg {
183760c2415Smrg if (unlikely (*src <= minval))
184760c2415Smrg {
185760c2415Smrg minval = *src;
186760c2415Smrg result = (GFC_INTEGER_4)n + 1;
187760c2415Smrg }
188760c2415Smrg }
189760c2415Smrg else
190760c2415Smrg for (; n < len; n++, src += delta)
191760c2415Smrg {
192760c2415Smrg if (unlikely (*src < minval))
193760c2415Smrg {
194760c2415Smrg minval = *src;
195760c2415Smrg result = (GFC_INTEGER_4) n + 1;
196760c2415Smrg }
197760c2415Smrg }
198760c2415Smrg
199760c2415Smrg *dest = result;
200760c2415Smrg }
201760c2415Smrg }
202760c2415Smrg /* Advance to the next element. */
203760c2415Smrg count[0]++;
204760c2415Smrg base += sstride[0];
205760c2415Smrg dest += dstride[0];
206760c2415Smrg n = 0;
207760c2415Smrg while (count[n] == extent[n])
208760c2415Smrg {
209760c2415Smrg /* When we get to the end of a dimension, reset it and increment
210760c2415Smrg the next dimension. */
211760c2415Smrg count[n] = 0;
212760c2415Smrg /* We could precalculate these products, but this is a less
213760c2415Smrg frequently used path so probably not worth it. */
214760c2415Smrg base -= sstride[n] * extent[n];
215760c2415Smrg dest -= dstride[n] * extent[n];
216760c2415Smrg n++;
217760c2415Smrg if (n >= rank)
218760c2415Smrg {
219760c2415Smrg /* Break out of the loop. */
220760c2415Smrg continue_loop = 0;
221760c2415Smrg break;
222760c2415Smrg }
223760c2415Smrg else
224760c2415Smrg {
225760c2415Smrg count[n]++;
226760c2415Smrg base += sstride[n];
227760c2415Smrg dest += dstride[n];
228760c2415Smrg }
229760c2415Smrg }
230760c2415Smrg }
231760c2415Smrg }
232760c2415Smrg
233760c2415Smrg
234760c2415Smrg extern void mminloc1_4_r10 (gfc_array_i4 * const restrict,
235760c2415Smrg gfc_array_r10 * const restrict, const index_type * const restrict,
236760c2415Smrg gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
237760c2415Smrg export_proto(mminloc1_4_r10);
238760c2415Smrg
239760c2415Smrg void
240760c2415Smrg mminloc1_4_r10 (gfc_array_i4 * const restrict retarray,
241760c2415Smrg gfc_array_r10 * const restrict array,
242760c2415Smrg const index_type * const restrict pdim,
243760c2415Smrg gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
244760c2415Smrg {
245760c2415Smrg index_type count[GFC_MAX_DIMENSIONS];
246760c2415Smrg index_type extent[GFC_MAX_DIMENSIONS];
247760c2415Smrg index_type sstride[GFC_MAX_DIMENSIONS];
248760c2415Smrg index_type dstride[GFC_MAX_DIMENSIONS];
249760c2415Smrg index_type mstride[GFC_MAX_DIMENSIONS];
250760c2415Smrg GFC_INTEGER_4 * restrict dest;
251760c2415Smrg const GFC_REAL_10 * restrict base;
252760c2415Smrg const GFC_LOGICAL_1 * restrict mbase;
253760c2415Smrg index_type rank;
254760c2415Smrg index_type dim;
255760c2415Smrg index_type n;
256760c2415Smrg index_type len;
257760c2415Smrg index_type delta;
258760c2415Smrg index_type mdelta;
259760c2415Smrg int mask_kind;
260760c2415Smrg
261760c2415Smrg if (mask == NULL)
262760c2415Smrg {
263760c2415Smrg #ifdef HAVE_BACK_ARG
264760c2415Smrg minloc1_4_r10 (retarray, array, pdim, back);
265760c2415Smrg #else
266760c2415Smrg minloc1_4_r10 (retarray, array, pdim);
267760c2415Smrg #endif
268760c2415Smrg return;
269760c2415Smrg }
270760c2415Smrg
271760c2415Smrg dim = (*pdim) - 1;
272760c2415Smrg rank = GFC_DESCRIPTOR_RANK (array) - 1;
273760c2415Smrg
274760c2415Smrg
275760c2415Smrg if (unlikely (dim < 0 || dim > rank))
276760c2415Smrg {
277760c2415Smrg runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
278760c2415Smrg "is %ld, should be between 1 and %ld",
279760c2415Smrg (long int) dim + 1, (long int) rank + 1);
280760c2415Smrg }
281760c2415Smrg
282760c2415Smrg len = GFC_DESCRIPTOR_EXTENT(array,dim);
283760c2415Smrg if (len <= 0)
284760c2415Smrg return;
285760c2415Smrg
286760c2415Smrg mbase = mask->base_addr;
287760c2415Smrg
288760c2415Smrg mask_kind = GFC_DESCRIPTOR_SIZE (mask);
289760c2415Smrg
290760c2415Smrg if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
291760c2415Smrg #ifdef HAVE_GFC_LOGICAL_16
292760c2415Smrg || mask_kind == 16
293760c2415Smrg #endif
294760c2415Smrg )
295760c2415Smrg mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
296760c2415Smrg else
297760c2415Smrg runtime_error ("Funny sized logical array");
298760c2415Smrg
299760c2415Smrg delta = GFC_DESCRIPTOR_STRIDE(array,dim);
300760c2415Smrg mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
301760c2415Smrg
302760c2415Smrg for (n = 0; n < dim; n++)
303760c2415Smrg {
304760c2415Smrg sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
305760c2415Smrg mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
306760c2415Smrg extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
307760c2415Smrg
308760c2415Smrg if (extent[n] < 0)
309760c2415Smrg extent[n] = 0;
310760c2415Smrg
311760c2415Smrg }
312760c2415Smrg for (n = dim; n < rank; n++)
313760c2415Smrg {
314760c2415Smrg sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
315760c2415Smrg mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
316760c2415Smrg extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
317760c2415Smrg
318760c2415Smrg if (extent[n] < 0)
319760c2415Smrg extent[n] = 0;
320760c2415Smrg }
321760c2415Smrg
322760c2415Smrg if (retarray->base_addr == NULL)
323760c2415Smrg {
324760c2415Smrg size_t alloc_size, str;
325760c2415Smrg
326760c2415Smrg for (n = 0; n < rank; n++)
327760c2415Smrg {
328760c2415Smrg if (n == 0)
329760c2415Smrg str = 1;
330760c2415Smrg else
331760c2415Smrg str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
332760c2415Smrg
333760c2415Smrg GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
334760c2415Smrg
335760c2415Smrg }
336760c2415Smrg
337760c2415Smrg alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
338760c2415Smrg
339760c2415Smrg retarray->offset = 0;
340760c2415Smrg retarray->dtype.rank = rank;
341760c2415Smrg
342760c2415Smrg if (alloc_size == 0)
343760c2415Smrg {
344760c2415Smrg /* Make sure we have a zero-sized array. */
345760c2415Smrg GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
346760c2415Smrg return;
347760c2415Smrg }
348760c2415Smrg else
349760c2415Smrg retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
350760c2415Smrg
351760c2415Smrg }
352760c2415Smrg else
353760c2415Smrg {
354760c2415Smrg if (rank != GFC_DESCRIPTOR_RANK (retarray))
355760c2415Smrg runtime_error ("rank of return array incorrect in MINLOC intrinsic");
356760c2415Smrg
357760c2415Smrg if (unlikely (compile_options.bounds_check))
358760c2415Smrg {
359760c2415Smrg bounds_ifunction_return ((array_t *) retarray, extent,
360760c2415Smrg "return value", "MINLOC");
361760c2415Smrg bounds_equal_extents ((array_t *) mask, (array_t *) array,
362760c2415Smrg "MASK argument", "MINLOC");
363760c2415Smrg }
364760c2415Smrg }
365760c2415Smrg
366760c2415Smrg for (n = 0; n < rank; n++)
367760c2415Smrg {
368760c2415Smrg count[n] = 0;
369760c2415Smrg dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
370760c2415Smrg if (extent[n] <= 0)
371760c2415Smrg return;
372760c2415Smrg }
373760c2415Smrg
374760c2415Smrg dest = retarray->base_addr;
375760c2415Smrg base = array->base_addr;
376760c2415Smrg
377760c2415Smrg while (base)
378760c2415Smrg {
379760c2415Smrg const GFC_REAL_10 * restrict src;
380760c2415Smrg const GFC_LOGICAL_1 * restrict msrc;
381760c2415Smrg GFC_INTEGER_4 result;
382760c2415Smrg src = base;
383760c2415Smrg msrc = mbase;
384760c2415Smrg {
385760c2415Smrg
386760c2415Smrg GFC_REAL_10 minval;
387760c2415Smrg #if defined (GFC_REAL_10_INFINITY)
388760c2415Smrg minval = GFC_REAL_10_INFINITY;
389760c2415Smrg #else
390760c2415Smrg minval = GFC_REAL_10_HUGE;
391760c2415Smrg #endif
392760c2415Smrg #if defined (GFC_REAL_10_QUIET_NAN)
393760c2415Smrg GFC_INTEGER_4 result2 = 0;
394760c2415Smrg #endif
395760c2415Smrg result = 0;
396760c2415Smrg for (n = 0; n < len; n++, src += delta, msrc += mdelta)
397760c2415Smrg {
398760c2415Smrg
399760c2415Smrg if (*msrc)
400760c2415Smrg {
401760c2415Smrg #if defined (GFC_REAL_10_QUIET_NAN)
402760c2415Smrg if (!result2)
403760c2415Smrg result2 = (GFC_INTEGER_4)n + 1;
404760c2415Smrg if (*src <= minval)
405760c2415Smrg #endif
406760c2415Smrg {
407760c2415Smrg minval = *src;
408760c2415Smrg result = (GFC_INTEGER_4)n + 1;
409760c2415Smrg break;
410760c2415Smrg }
411760c2415Smrg }
412760c2415Smrg }
413760c2415Smrg #if defined (GFC_REAL_10_QUIET_NAN)
414760c2415Smrg if (unlikely (n >= len))
415760c2415Smrg result = result2;
416760c2415Smrg else
417760c2415Smrg #endif
418760c2415Smrg if (back)
419760c2415Smrg for (; n < len; n++, src += delta, msrc += mdelta)
420760c2415Smrg {
421760c2415Smrg if (*msrc && unlikely (*src <= minval))
422760c2415Smrg {
423760c2415Smrg minval = *src;
424760c2415Smrg result = (GFC_INTEGER_4)n + 1;
425760c2415Smrg }
426760c2415Smrg }
427760c2415Smrg else
428760c2415Smrg for (; n < len; n++, src += delta, msrc += mdelta)
429760c2415Smrg {
430760c2415Smrg if (*msrc && unlikely (*src < minval))
431760c2415Smrg {
432760c2415Smrg minval = *src;
433760c2415Smrg result = (GFC_INTEGER_4) n + 1;
434760c2415Smrg }
435760c2415Smrg }
436760c2415Smrg *dest = result;
437760c2415Smrg }
438760c2415Smrg /* Advance to the next element. */
439760c2415Smrg count[0]++;
440760c2415Smrg base += sstride[0];
441760c2415Smrg mbase += mstride[0];
442760c2415Smrg dest += dstride[0];
443760c2415Smrg n = 0;
444760c2415Smrg while (count[n] == extent[n])
445760c2415Smrg {
446760c2415Smrg /* When we get to the end of a dimension, reset it and increment
447760c2415Smrg the next dimension. */
448760c2415Smrg count[n] = 0;
449760c2415Smrg /* We could precalculate these products, but this is a less
450760c2415Smrg frequently used path so probably not worth it. */
451760c2415Smrg base -= sstride[n] * extent[n];
452760c2415Smrg mbase -= mstride[n] * extent[n];
453760c2415Smrg dest -= dstride[n] * extent[n];
454760c2415Smrg n++;
455760c2415Smrg if (n >= rank)
456760c2415Smrg {
457760c2415Smrg /* Break out of the loop. */
458760c2415Smrg base = NULL;
459760c2415Smrg break;
460760c2415Smrg }
461760c2415Smrg else
462760c2415Smrg {
463760c2415Smrg count[n]++;
464760c2415Smrg base += sstride[n];
465760c2415Smrg mbase += mstride[n];
466760c2415Smrg dest += dstride[n];
467760c2415Smrg }
468760c2415Smrg }
469760c2415Smrg }
470760c2415Smrg }
471760c2415Smrg
472760c2415Smrg
473760c2415Smrg extern void sminloc1_4_r10 (gfc_array_i4 * const restrict,
474760c2415Smrg gfc_array_r10 * const restrict, const index_type * const restrict,
475760c2415Smrg GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
476760c2415Smrg export_proto(sminloc1_4_r10);
477760c2415Smrg
478760c2415Smrg void
479760c2415Smrg sminloc1_4_r10 (gfc_array_i4 * const restrict retarray,
480760c2415Smrg gfc_array_r10 * const restrict array,
481760c2415Smrg const index_type * const restrict pdim,
482760c2415Smrg GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
483760c2415Smrg {
484760c2415Smrg index_type count[GFC_MAX_DIMENSIONS];
485760c2415Smrg index_type extent[GFC_MAX_DIMENSIONS];
486760c2415Smrg index_type dstride[GFC_MAX_DIMENSIONS];
487760c2415Smrg GFC_INTEGER_4 * restrict dest;
488760c2415Smrg index_type rank;
489760c2415Smrg index_type n;
490760c2415Smrg index_type dim;
491760c2415Smrg
492760c2415Smrg
493760c2415Smrg if (mask == NULL || *mask)
494760c2415Smrg {
495760c2415Smrg #ifdef HAVE_BACK_ARG
496760c2415Smrg minloc1_4_r10 (retarray, array, pdim, back);
497760c2415Smrg #else
498760c2415Smrg minloc1_4_r10 (retarray, array, pdim);
499760c2415Smrg #endif
500760c2415Smrg return;
501760c2415Smrg }
502760c2415Smrg /* Make dim zero based to avoid confusion. */
503760c2415Smrg dim = (*pdim) - 1;
504760c2415Smrg rank = GFC_DESCRIPTOR_RANK (array) - 1;
505760c2415Smrg
506760c2415Smrg if (unlikely (dim < 0 || dim > rank))
507760c2415Smrg {
508760c2415Smrg runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
509760c2415Smrg "is %ld, should be between 1 and %ld",
510760c2415Smrg (long int) dim + 1, (long int) rank + 1);
511760c2415Smrg }
512760c2415Smrg
513760c2415Smrg for (n = 0; n < dim; n++)
514760c2415Smrg {
515760c2415Smrg extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
516760c2415Smrg
517760c2415Smrg if (extent[n] <= 0)
518760c2415Smrg extent[n] = 0;
519760c2415Smrg }
520760c2415Smrg
521760c2415Smrg for (n = dim; n < rank; n++)
522760c2415Smrg {
523760c2415Smrg extent[n] =
524760c2415Smrg GFC_DESCRIPTOR_EXTENT(array,n + 1);
525760c2415Smrg
526760c2415Smrg if (extent[n] <= 0)
527760c2415Smrg extent[n] = 0;
528760c2415Smrg }
529760c2415Smrg
530760c2415Smrg if (retarray->base_addr == NULL)
531760c2415Smrg {
532760c2415Smrg size_t alloc_size, str;
533760c2415Smrg
534760c2415Smrg for (n = 0; n < rank; n++)
535760c2415Smrg {
536760c2415Smrg if (n == 0)
537760c2415Smrg str = 1;
538760c2415Smrg else
539760c2415Smrg str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
540760c2415Smrg
541760c2415Smrg GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
542760c2415Smrg
543760c2415Smrg }
544760c2415Smrg
545760c2415Smrg retarray->offset = 0;
546760c2415Smrg retarray->dtype.rank = rank;
547760c2415Smrg
548760c2415Smrg alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
549760c2415Smrg
550760c2415Smrg if (alloc_size == 0)
551760c2415Smrg {
552760c2415Smrg /* Make sure we have a zero-sized array. */
553760c2415Smrg GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
554760c2415Smrg return;
555760c2415Smrg }
556760c2415Smrg else
557760c2415Smrg retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
558760c2415Smrg }
559760c2415Smrg else
560760c2415Smrg {
561760c2415Smrg if (rank != GFC_DESCRIPTOR_RANK (retarray))
562760c2415Smrg runtime_error ("rank of return array incorrect in"
563760c2415Smrg " MINLOC intrinsic: is %ld, should be %ld",
564760c2415Smrg (long int) (GFC_DESCRIPTOR_RANK (retarray)),
565760c2415Smrg (long int) rank);
566760c2415Smrg
567760c2415Smrg if (unlikely (compile_options.bounds_check))
568760c2415Smrg {
569760c2415Smrg for (n=0; n < rank; n++)
570760c2415Smrg {
571760c2415Smrg index_type ret_extent;
572760c2415Smrg
573760c2415Smrg ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
574760c2415Smrg if (extent[n] != ret_extent)
575760c2415Smrg runtime_error ("Incorrect extent in return value of"
576760c2415Smrg " MINLOC intrinsic in dimension %ld:"
577760c2415Smrg " is %ld, should be %ld", (long int) n + 1,
578760c2415Smrg (long int) ret_extent, (long int) extent[n]);
579760c2415Smrg }
580760c2415Smrg }
581760c2415Smrg }
582760c2415Smrg
583760c2415Smrg for (n = 0; n < rank; n++)
584760c2415Smrg {
585760c2415Smrg count[n] = 0;
586760c2415Smrg dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
587760c2415Smrg }
588760c2415Smrg
589760c2415Smrg dest = retarray->base_addr;
590760c2415Smrg
591760c2415Smrg while(1)
592760c2415Smrg {
593760c2415Smrg *dest = 0;
594760c2415Smrg count[0]++;
595760c2415Smrg dest += dstride[0];
596760c2415Smrg n = 0;
597760c2415Smrg while (count[n] == extent[n])
598760c2415Smrg {
599760c2415Smrg /* When we get to the end of a dimension, reset it and increment
600760c2415Smrg the next dimension. */
601760c2415Smrg count[n] = 0;
602760c2415Smrg /* We could precalculate these products, but this is a less
603760c2415Smrg frequently used path so probably not worth it. */
604760c2415Smrg dest -= dstride[n] * extent[n];
605760c2415Smrg n++;
606760c2415Smrg if (n >= rank)
607760c2415Smrg return;
608760c2415Smrg else
609760c2415Smrg {
610760c2415Smrg count[n]++;
611760c2415Smrg dest += dstride[n];
612760c2415Smrg }
613760c2415Smrg }
614760c2415Smrg }
615760c2415Smrg }
616760c2415Smrg
617760c2415Smrg #endif
618