1/* Implementation of the MAXLOC intrinsic
2   Copyright (C) 2002-2020 Free Software Foundation, Inc.
3   Contributed by Paul Brook <paul@nowt.org>
4
5This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
7Libgfortran is free software; you can redistribute it and/or
8modify it under the terms of the GNU General Public
9License as published by the Free Software Foundation; either
10version 3 of the License, or (at your option) any later version.
11
12Libgfortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.
16
17Under Section 7 of GPL version 3, you are granted additional
18permissions described in the GCC Runtime Library Exception, version
193.1, as published by the Free Software Foundation.
20
21You should have received a copy of the GNU General Public License and
22a copy of the GCC Runtime Library Exception along with this program;
23see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
24<http://www.gnu.org/licenses/>.  */
25
26#include "libgfortran.h"
27#include <assert.h>
28
29
30#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_8)
31
32
33extern void maxloc0_8_r16 (gfc_array_i8 * const restrict retarray,
34	gfc_array_r16 * const restrict array, GFC_LOGICAL_4);
35export_proto(maxloc0_8_r16);
36
37void
38maxloc0_8_r16 (gfc_array_i8 * const restrict retarray,
39	gfc_array_r16 * const restrict array, GFC_LOGICAL_4 back)
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;
45  const GFC_REAL_16 *base;
46  GFC_INTEGER_8 * restrict dest;
47  index_type rank;
48  index_type n;
49
50  rank = GFC_DESCRIPTOR_RANK (array);
51  if (rank <= 0)
52    runtime_error ("Rank of array needs to be > 0");
53
54  if (retarray->base_addr == NULL)
55    {
56      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
57      retarray->dtype.rank = 1;
58      retarray->offset = 0;
59      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
60    }
61  else
62    {
63      if (unlikely (compile_options.bounds_check))
64	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
65				"MAXLOC");
66    }
67
68  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
69  dest = retarray->base_addr;
70  for (n = 0; n < rank; n++)
71    {
72      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
73      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
74      count[n] = 0;
75      if (extent[n] <= 0)
76	{
77	  /* Set the return value.  */
78	  for (n = 0; n < rank; n++)
79	    dest[n * dstride] = 0;
80	  return;
81	}
82    }
83
84  base = array->base_addr;
85
86  /* Initialize the return value.  */
87  for (n = 0; n < rank; n++)
88    dest[n * dstride] = 1;
89  {
90
91    GFC_REAL_16 maxval;
92#if defined(GFC_REAL_16_QUIET_NAN)
93    int fast = 0;
94#endif
95
96#if defined(GFC_REAL_16_INFINITY)
97    maxval = -GFC_REAL_16_INFINITY;
98#else
99    maxval = -GFC_REAL_16_HUGE;
100#endif
101  while (base)
102    {
103	  /* Implementation start.  */
104
105#if defined(GFC_REAL_16_QUIET_NAN)
106      if (unlikely (!fast))
107	{
108	  do
109	    {
110	      if (*base >= maxval)
111		{
112		  fast = 1;
113		  maxval = *base;
114		  for (n = 0; n < rank; n++)
115		    dest[n * dstride] = count[n] + 1;
116		  break;
117		}
118	      base += sstride[0];
119	    }
120	  while (++count[0] != extent[0]);
121	  if (likely (fast))
122	    continue;
123	}
124      else
125#endif
126        if (back)
127      	  do
128            {
129	      if (unlikely (*base >= maxval))
130	       {
131	         maxval = *base;
132	      	 for (n = 0; n < rank; n++)
133		   dest[n * dstride] = count[n] + 1;
134	       }
135	     base += sstride[0];
136	   }
137         while (++count[0] != extent[0]);
138       else
139         do
140	   {
141	     if (unlikely (*base > maxval))
142	       {
143	         maxval = *base;
144		 for (n = 0; n < rank; n++)
145		   dest[n * dstride] = count[n] + 1;
146	       }
147	  /* Implementation end.  */
148	  /* Advance to the next element.  */
149	  base += sstride[0];
150	}
151      while (++count[0] != extent[0]);
152      n = 0;
153      do
154	{
155	  /* When we get to the end of a dimension, reset it and increment
156	     the next dimension.  */
157	  count[n] = 0;
158	  /* We could precalculate these products, but this is a less
159	     frequently used path so probably not worth it.  */
160	  base -= sstride[n] * extent[n];
161	  n++;
162	  if (n >= rank)
163	    {
164	      /* Break out of the loop.  */
165	      base = NULL;
166	      break;
167	    }
168	  else
169	    {
170	      count[n]++;
171	      base += sstride[n];
172	    }
173	}
174      while (count[n] == extent[n]);
175    }
176  }
177}
178
179extern void mmaxloc0_8_r16 (gfc_array_i8 * const restrict,
180	gfc_array_r16 * const restrict, gfc_array_l1 * const restrict,
181	GFC_LOGICAL_4);
182export_proto(mmaxloc0_8_r16);
183
184void
185mmaxloc0_8_r16 (gfc_array_i8 * const restrict retarray,
186	gfc_array_r16 * const restrict array,
187	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
188{
189  index_type count[GFC_MAX_DIMENSIONS];
190  index_type extent[GFC_MAX_DIMENSIONS];
191  index_type sstride[GFC_MAX_DIMENSIONS];
192  index_type mstride[GFC_MAX_DIMENSIONS];
193  index_type dstride;
194  GFC_INTEGER_8 *dest;
195  const GFC_REAL_16 *base;
196  GFC_LOGICAL_1 *mbase;
197  int rank;
198  index_type n;
199  int mask_kind;
200
201
202  if (mask == NULL)
203    {
204      maxloc0_8_r16 (retarray, array, back);
205      return;
206    }
207
208  rank = GFC_DESCRIPTOR_RANK (array);
209  if (rank <= 0)
210    runtime_error ("Rank of array needs to be > 0");
211
212  if (retarray->base_addr == NULL)
213    {
214      GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
215      retarray->dtype.rank = 1;
216      retarray->offset = 0;
217      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
218    }
219  else
220    {
221      if (unlikely (compile_options.bounds_check))
222	{
223
224	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
225				  "MAXLOC");
226	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
227				  "MASK argument", "MAXLOC");
228	}
229    }
230
231  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
232
233  mbase = mask->base_addr;
234
235  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
236#ifdef HAVE_GFC_LOGICAL_16
237      || mask_kind == 16
238#endif
239      )
240    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
241  else
242    runtime_error ("Funny sized logical array");
243
244  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
245  dest = retarray->base_addr;
246  for (n = 0; n < rank; n++)
247    {
248      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
249      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
250      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
251      count[n] = 0;
252      if (extent[n] <= 0)
253	{
254	  /* Set the return value.  */
255	  for (n = 0; n < rank; n++)
256	    dest[n * dstride] = 0;
257	  return;
258	}
259    }
260
261  base = array->base_addr;
262
263  /* Initialize the return value.  */
264  for (n = 0; n < rank; n++)
265    dest[n * dstride] = 0;
266  {
267
268  GFC_REAL_16 maxval;
269   int fast = 0;
270
271#if defined(GFC_REAL_16_INFINITY)
272    maxval = -GFC_REAL_16_INFINITY;
273#else
274    maxval = -GFC_REAL_16_HUGE;
275#endif
276  while (base)
277    {
278	  /* Implementation start.  */
279
280      if (unlikely (!fast))
281	{
282	  do
283	    {
284	      if (*mbase)
285		{
286#if defined(GFC_REAL_16_QUIET_NAN)
287		  if (unlikely (dest[0] == 0))
288		    for (n = 0; n < rank; n++)
289		      dest[n * dstride] = count[n] + 1;
290		  if (*base >= maxval)
291#endif
292		    {
293		      fast = 1;
294		      maxval = *base;
295		      for (n = 0; n < rank; n++)
296			dest[n * dstride] = count[n] + 1;
297		      break;
298		    }
299		}
300	      base += sstride[0];
301	      mbase += mstride[0];
302	    }
303	  while (++count[0] != extent[0]);
304	  if (likely (fast))
305	    continue;
306	}
307      else
308        if (back)
309	  do
310	    {
311	      if (*mbase && *base >= maxval)
312	        {
313	          maxval = *base;
314	          for (n = 0; n < rank; n++)
315		    dest[n * dstride] = count[n] + 1;
316		}
317	      base += sstride[0];
318	    }
319	  while (++count[0] != extent[0]);
320	else
321	  do
322	    {
323	      if (*mbase && unlikely (*base > maxval))
324	        {
325		  maxval = *base;
326		  for (n = 0; n < rank; n++)
327		    dest[n * dstride] = count[n] + 1;
328	        }
329	  /* Implementation end.  */
330	  /* Advance to the next element.  */
331	  base += sstride[0];
332	  mbase += mstride[0];
333	}
334      while (++count[0] != extent[0]);
335      n = 0;
336      do
337	{
338	  /* When we get to the end of a dimension, reset it and increment
339	     the next dimension.  */
340	  count[n] = 0;
341	  /* We could precalculate these products, but this is a less
342	     frequently used path so probably not worth it.  */
343	  base -= sstride[n] * extent[n];
344	  mbase -= mstride[n] * extent[n];
345	  n++;
346	  if (n >= rank)
347	    {
348	      /* Break out of the loop.  */
349	      base = NULL;
350	      break;
351	    }
352	  else
353	    {
354	      count[n]++;
355	      base += sstride[n];
356	      mbase += mstride[n];
357	    }
358	}
359      while (count[n] == extent[n]);
360    }
361  }
362}
363
364
365extern void smaxloc0_8_r16 (gfc_array_i8 * const restrict,
366	gfc_array_r16 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
367export_proto(smaxloc0_8_r16);
368
369void
370smaxloc0_8_r16 (gfc_array_i8 * const restrict retarray,
371	gfc_array_r16 * const restrict array,
372	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
373{
374  index_type rank;
375  index_type dstride;
376  index_type n;
377  GFC_INTEGER_8 *dest;
378
379  if (mask == NULL || *mask)
380    {
381      maxloc0_8_r16 (retarray, array, back);
382      return;
383    }
384
385  rank = GFC_DESCRIPTOR_RANK (array);
386
387  if (rank <= 0)
388    runtime_error ("Rank of array needs to be > 0");
389
390  if (retarray->base_addr == NULL)
391    {
392      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
393      retarray->dtype.rank = 1;
394      retarray->offset = 0;
395      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
396    }
397  else if (unlikely (compile_options.bounds_check))
398    {
399       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
400			       "MAXLOC");
401    }
402
403  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
404  dest = retarray->base_addr;
405  for (n = 0; n<rank; n++)
406    dest[n * dstride] = 0 ;
407}
408#endif
409