1 /* Implementation of the MAXLOC intrinsic
2 Copyright (C) 2002-2023 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 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_4) && defined (HAVE_GFC_INTEGER_4)
32 #define HAVE_BACK_ARG 1
35 extern void maxloc1_4_i4 (gfc_array_i4
* const restrict
,
36 gfc_array_i4
* const restrict
, const index_type
* const restrict
, GFC_LOGICAL_4 back
);
37 export_proto(maxloc1_4_i4
);
40 maxloc1_4_i4 (gfc_array_i4
* const restrict retarray
,
41 gfc_array_i4
* const restrict array
,
42 const index_type
* const restrict pdim
, GFC_LOGICAL_4 back
)
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_4
* restrict base
;
49 GFC_INTEGER_4
* restrict dest
;
57 /* Make dim zero based to avoid confusion. */
58 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
61 if (unlikely (dim
< 0 || dim
> rank
))
63 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
64 "is %ld, should be between 1 and %ld",
65 (long int) dim
+ 1, (long int) rank
+ 1);
68 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
71 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
73 for (n
= 0; n
< dim
; n
++)
75 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
76 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
81 for (n
= dim
; n
< rank
; n
++)
83 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
84 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
90 if (retarray
->base_addr
== NULL
)
92 size_t alloc_size
, str
;
94 for (n
= 0; n
< rank
; n
++)
99 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
101 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
105 retarray
->offset
= 0;
106 retarray
->dtype
.rank
= rank
;
108 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
110 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
113 /* Make sure we have a zero-sized array. */
114 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
121 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
122 runtime_error ("rank of return array incorrect in"
123 " MAXLOC intrinsic: is %ld, should be %ld",
124 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
127 if (unlikely (compile_options
.bounds_check
))
128 bounds_ifunction_return ((array_t
*) retarray
, extent
,
129 "return value", "MAXLOC");
132 for (n
= 0; n
< rank
; n
++)
135 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
140 base
= array
->base_addr
;
141 dest
= retarray
->base_addr
;
144 while (continue_loop
)
146 const GFC_INTEGER_4
* restrict src
;
147 GFC_INTEGER_4 result
;
151 GFC_INTEGER_4 maxval
;
152 #if defined (GFC_INTEGER_4_INFINITY)
153 maxval
= -GFC_INTEGER_4_INFINITY
;
155 maxval
= (-GFC_INTEGER_4_HUGE
-1);
162 #if ! defined HAVE_BACK_ARG
163 for (n
= 0; n
< len
; n
++, src
+= delta
)
167 #if defined (GFC_INTEGER_4_QUIET_NAN)
168 for (n
= 0; n
< len
; n
++, src
+= delta
)
173 result
= (GFC_INTEGER_4
)n
+ 1;
180 for (; n
< len
; n
++, src
+= delta
)
182 if (back
? *src
>= maxval
: *src
> maxval
)
185 result
= (GFC_INTEGER_4
)n
+ 1;
192 /* Advance to the next element. */
197 while (count
[n
] == extent
[n
])
199 /* When we get to the end of a dimension, reset it and increment
200 the next dimension. */
202 /* We could precalculate these products, but this is a less
203 frequently used path so probably not worth it. */
204 base
-= sstride
[n
] * extent
[n
];
205 dest
-= dstride
[n
] * extent
[n
];
209 /* Break out of the loop. */
224 extern void mmaxloc1_4_i4 (gfc_array_i4
* const restrict
,
225 gfc_array_i4
* const restrict
, const index_type
* const restrict
,
226 gfc_array_l1
* const restrict
, GFC_LOGICAL_4 back
);
227 export_proto(mmaxloc1_4_i4
);
230 mmaxloc1_4_i4 (gfc_array_i4
* const restrict retarray
,
231 gfc_array_i4
* const restrict array
,
232 const index_type
* const restrict pdim
,
233 gfc_array_l1
* const restrict mask
, GFC_LOGICAL_4 back
)
235 index_type count
[GFC_MAX_DIMENSIONS
];
236 index_type extent
[GFC_MAX_DIMENSIONS
];
237 index_type sstride
[GFC_MAX_DIMENSIONS
];
238 index_type dstride
[GFC_MAX_DIMENSIONS
];
239 index_type mstride
[GFC_MAX_DIMENSIONS
];
240 GFC_INTEGER_4
* restrict dest
;
241 const GFC_INTEGER_4
* restrict base
;
242 const GFC_LOGICAL_1
* restrict mbase
;
254 maxloc1_4_i4 (retarray
, array
, pdim
, back
);
256 maxloc1_4_i4 (retarray
, array
, pdim
);
262 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
265 if (unlikely (dim
< 0 || dim
> rank
))
267 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
268 "is %ld, should be between 1 and %ld",
269 (long int) dim
+ 1, (long int) rank
+ 1);
272 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
276 mbase
= mask
->base_addr
;
278 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
280 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
281 #ifdef HAVE_GFC_LOGICAL_16
285 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
287 runtime_error ("Funny sized logical array");
289 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
290 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
292 for (n
= 0; n
< dim
; n
++)
294 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
295 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
296 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
302 for (n
= dim
; n
< rank
; n
++)
304 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
305 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
306 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
312 if (retarray
->base_addr
== NULL
)
314 size_t alloc_size
, str
;
316 for (n
= 0; n
< rank
; n
++)
321 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
323 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
327 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
329 retarray
->offset
= 0;
330 retarray
->dtype
.rank
= rank
;
334 /* Make sure we have a zero-sized array. */
335 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
339 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
344 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
345 runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
347 if (unlikely (compile_options
.bounds_check
))
349 bounds_ifunction_return ((array_t
*) retarray
, extent
,
350 "return value", "MAXLOC");
351 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
352 "MASK argument", "MAXLOC");
356 for (n
= 0; n
< rank
; n
++)
359 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
364 dest
= retarray
->base_addr
;
365 base
= array
->base_addr
;
369 const GFC_INTEGER_4
* restrict src
;
370 const GFC_LOGICAL_1
* restrict msrc
;
371 GFC_INTEGER_4 result
;
376 GFC_INTEGER_4 maxval
;
377 #if defined (GFC_INTEGER_4_INFINITY)
378 maxval
= -GFC_INTEGER_4_INFINITY
;
380 maxval
= (-GFC_INTEGER_4_HUGE
-1);
382 #if defined (GFC_INTEGER_4_QUIET_NAN)
383 GFC_INTEGER_4 result2
= 0;
386 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
391 #if defined (GFC_INTEGER_4_QUIET_NAN)
393 result2
= (GFC_INTEGER_4
)n
+ 1;
398 result
= (GFC_INTEGER_4
)n
+ 1;
403 #if defined (GFC_INTEGER_4_QUIET_NAN)
404 if (unlikely (n
>= len
))
409 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
411 if (*msrc
&& unlikely (*src
>= maxval
))
414 result
= (GFC_INTEGER_4
)n
+ 1;
418 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
420 if (*msrc
&& unlikely (*src
> maxval
))
423 result
= (GFC_INTEGER_4
)n
+ 1;
428 /* Advance to the next element. */
434 while (count
[n
] == extent
[n
])
436 /* When we get to the end of a dimension, reset it and increment
437 the next dimension. */
439 /* We could precalculate these products, but this is a less
440 frequently used path so probably not worth it. */
441 base
-= sstride
[n
] * extent
[n
];
442 mbase
-= mstride
[n
] * extent
[n
];
443 dest
-= dstride
[n
] * extent
[n
];
447 /* Break out of the loop. */
463 extern void smaxloc1_4_i4 (gfc_array_i4
* const restrict
,
464 gfc_array_i4
* const restrict
, const index_type
* const restrict
,
465 GFC_LOGICAL_4
*, GFC_LOGICAL_4 back
);
466 export_proto(smaxloc1_4_i4
);
469 smaxloc1_4_i4 (gfc_array_i4
* const restrict retarray
,
470 gfc_array_i4
* const restrict array
,
471 const index_type
* const restrict pdim
,
472 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
)
474 index_type count
[GFC_MAX_DIMENSIONS
];
475 index_type extent
[GFC_MAX_DIMENSIONS
];
476 index_type dstride
[GFC_MAX_DIMENSIONS
];
477 GFC_INTEGER_4
* restrict dest
;
483 if (mask
== NULL
|| *mask
)
486 maxloc1_4_i4 (retarray
, array
, pdim
, back
);
488 maxloc1_4_i4 (retarray
, array
, pdim
);
492 /* Make dim zero based to avoid confusion. */
494 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
496 if (unlikely (dim
< 0 || dim
> rank
))
498 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
499 "is %ld, should be between 1 and %ld",
500 (long int) dim
+ 1, (long int) rank
+ 1);
503 for (n
= 0; n
< dim
; n
++)
505 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
511 for (n
= dim
; n
< rank
; n
++)
514 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
520 if (retarray
->base_addr
== NULL
)
522 size_t alloc_size
, str
;
524 for (n
= 0; n
< rank
; n
++)
529 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
531 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
535 retarray
->offset
= 0;
536 retarray
->dtype
.rank
= rank
;
538 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
542 /* Make sure we have a zero-sized array. */
543 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
547 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
551 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
552 runtime_error ("rank of return array incorrect in"
553 " MAXLOC intrinsic: is %ld, should be %ld",
554 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
557 if (unlikely (compile_options
.bounds_check
))
559 for (n
=0; n
< rank
; n
++)
561 index_type ret_extent
;
563 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
564 if (extent
[n
] != ret_extent
)
565 runtime_error ("Incorrect extent in return value of"
566 " MAXLOC intrinsic in dimension %ld:"
567 " is %ld, should be %ld", (long int) n
+ 1,
568 (long int) ret_extent
, (long int) extent
[n
]);
573 for (n
= 0; n
< rank
; n
++)
576 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
579 dest
= retarray
->base_addr
;
587 while (count
[n
] == extent
[n
])
589 /* When we get to the end of a dimension, reset it and increment
590 the next dimension. */
592 /* We could precalculate these products, but this is a less
593 frequently used path so probably not worth it. */
594 dest
-= dstride
[n
] * extent
[n
];