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