1 /* Implementation of the MAXLOC intrinsic
2 Copyright (C) 2002-2024 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
30 #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_8)
33 extern void maxloc0_8_i2 (gfc_array_i8
* const restrict retarray
,
34 gfc_array_i2
* const restrict array
, GFC_LOGICAL_4
);
35 export_proto(maxloc0_8_i2
);
38 maxloc0_8_i2 (gfc_array_i8
* const restrict retarray
,
39 gfc_array_i2
* const restrict array
, GFC_LOGICAL_4 back
)
41 index_type count
[GFC_MAX_DIMENSIONS
];
42 index_type extent
[GFC_MAX_DIMENSIONS
];
43 index_type sstride
[GFC_MAX_DIMENSIONS
];
45 const GFC_INTEGER_2
*base
;
46 GFC_INTEGER_8
* restrict dest
;
50 rank
= GFC_DESCRIPTOR_RANK (array
);
52 runtime_error ("Rank of array needs to be > 0");
54 if (retarray
->base_addr
== NULL
)
56 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
57 retarray
->dtype
.rank
= 1;
59 retarray
->base_addr
= xmallocarray (rank
, sizeof (GFC_INTEGER_8
));
63 if (unlikely (compile_options
.bounds_check
))
64 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
68 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
69 dest
= retarray
->base_addr
;
70 for (n
= 0; n
< rank
; n
++)
72 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
73 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
77 /* Set the return value. */
78 for (n
= 0; n
< rank
; n
++)
79 dest
[n
* dstride
] = 0;
84 base
= array
->base_addr
;
86 /* Initialize the return value. */
87 for (n
= 0; n
< rank
; n
++)
88 dest
[n
* dstride
] = 1;
92 #if defined(GFC_INTEGER_2_QUIET_NAN)
96 #if defined(GFC_INTEGER_2_INFINITY)
97 maxval
= -GFC_INTEGER_2_INFINITY
;
99 maxval
= (-GFC_INTEGER_2_HUGE
-1);
103 /* Implementation start. */
105 #if defined(GFC_INTEGER_2_QUIET_NAN)
106 if (unlikely (!fast
))
114 for (n
= 0; n
< rank
; n
++)
115 dest
[n
* dstride
] = count
[n
] + 1;
120 while (++count
[0] != extent
[0]);
129 if (unlikely (*base
>= maxval
))
132 for (n
= 0; n
< rank
; n
++)
133 dest
[n
* dstride
] = count
[n
] + 1;
137 while (++count
[0] != extent
[0]);
141 if (unlikely (*base
> maxval
))
144 for (n
= 0; n
< rank
; n
++)
145 dest
[n
* dstride
] = count
[n
] + 1;
147 /* Implementation end. */
148 /* Advance to the next element. */
151 while (++count
[0] != extent
[0]);
155 /* When we get to the end of a dimension, reset it and increment
156 the next dimension. */
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
];
164 /* Break out of the loop. */
174 while (count
[n
] == extent
[n
]);
179 extern void mmaxloc0_8_i2 (gfc_array_i8
* const restrict
,
180 gfc_array_i2
* const restrict
, gfc_array_l1
* const restrict
,
182 export_proto(mmaxloc0_8_i2
);
185 mmaxloc0_8_i2 (gfc_array_i8
* const restrict retarray
,
186 gfc_array_i2
* const restrict array
,
187 gfc_array_l1
* const restrict mask
, GFC_LOGICAL_4 back
)
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
];
195 const GFC_INTEGER_2
*base
;
196 GFC_LOGICAL_1
*mbase
;
204 maxloc0_8_i2 (retarray
, array
, back
);
208 rank
= GFC_DESCRIPTOR_RANK (array
);
210 runtime_error ("Rank of array needs to be > 0");
212 if (retarray
->base_addr
== NULL
)
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
));
221 if (unlikely (compile_options
.bounds_check
))
224 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
226 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
227 "MASK argument", "MAXLOC");
231 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
233 mbase
= mask
->base_addr
;
235 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
236 #ifdef HAVE_GFC_LOGICAL_16
240 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
242 runtime_error ("Funny sized logical array");
244 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
245 dest
= retarray
->base_addr
;
246 for (n
= 0; n
< rank
; n
++)
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
);
254 /* Set the return value. */
255 for (n
= 0; n
< rank
; n
++)
256 dest
[n
* dstride
] = 0;
261 base
= array
->base_addr
;
263 /* Initialize the return value. */
264 for (n
= 0; n
< rank
; n
++)
265 dest
[n
* dstride
] = 0;
268 GFC_INTEGER_2 maxval
;
271 #if defined(GFC_INTEGER_2_INFINITY)
272 maxval
= -GFC_INTEGER_2_INFINITY
;
274 maxval
= (-GFC_INTEGER_2_HUGE
-1);
278 /* Implementation start. */
280 if (unlikely (!fast
))
286 #if defined(GFC_INTEGER_2_QUIET_NAN)
287 if (unlikely (dest
[0] == 0))
288 for (n
= 0; n
< rank
; n
++)
289 dest
[n
* dstride
] = count
[n
] + 1;
295 for (n
= 0; n
< rank
; n
++)
296 dest
[n
* dstride
] = count
[n
] + 1;
303 while (++count
[0] != extent
[0]);
311 if (*mbase
&& *base
>= maxval
)
314 for (n
= 0; n
< rank
; n
++)
315 dest
[n
* dstride
] = count
[n
] + 1;
319 while (++count
[0] != extent
[0]);
323 if (*mbase
&& unlikely (*base
> maxval
))
326 for (n
= 0; n
< rank
; n
++)
327 dest
[n
* dstride
] = count
[n
] + 1;
329 /* Implementation end. */
330 /* Advance to the next element. */
334 while (++count
[0] != extent
[0]);
338 /* When we get to the end of a dimension, reset it and increment
339 the next dimension. */
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
];
348 /* Break out of the loop. */
359 while (count
[n
] == extent
[n
]);
365 extern void smaxloc0_8_i2 (gfc_array_i8
* const restrict
,
366 gfc_array_i2
* const restrict
, GFC_LOGICAL_4
*, GFC_LOGICAL_4
);
367 export_proto(smaxloc0_8_i2
);
370 smaxloc0_8_i2 (gfc_array_i8
* const restrict retarray
,
371 gfc_array_i2
* const restrict array
,
372 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
)
379 if (mask
== NULL
|| *mask
)
381 maxloc0_8_i2 (retarray
, array
, back
);
385 rank
= GFC_DESCRIPTOR_RANK (array
);
388 runtime_error ("Rank of array needs to be > 0");
390 if (retarray
->base_addr
== NULL
)
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
));
397 else if (unlikely (compile_options
.bounds_check
))
399 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
403 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
404 dest
= retarray
->base_addr
;
405 for (n
= 0; n
<rank
; n
++)
406 dest
[n
* dstride
] = 0 ;