1 /* Implementation of the MINLOC 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 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_16) && defined (HAVE_GFC_INTEGER_16)
32 #define HAVE_BACK_ARG 1
35 extern void minloc1_16_i16 (gfc_array_i16
* const restrict
,
36 gfc_array_i16
* const restrict
, const index_type
* const restrict
, GFC_LOGICAL_4 back
);
37 export_proto(minloc1_16_i16
);
40 minloc1_16_i16 (gfc_array_i16
* const restrict retarray
,
41 gfc_array_i16
* 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_16
* restrict base
;
49 GFC_INTEGER_16
* 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 MINLOC 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_16
));
116 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
117 runtime_error ("rank of return array incorrect in"
118 " MINLOC intrinsic: is %ld, should be %ld",
119 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
122 if (unlikely (compile_options
.bounds_check
))
123 bounds_ifunction_return ((array_t
*) retarray
, extent
,
124 "return value", "MINLOC");
127 for (n
= 0; n
< rank
; n
++)
130 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
135 base
= array
->base_addr
;
136 dest
= retarray
->base_addr
;
139 while (continue_loop
)
141 const GFC_INTEGER_16
* restrict src
;
142 GFC_INTEGER_16 result
;
146 GFC_INTEGER_16 minval
;
147 #if defined (GFC_INTEGER_16_INFINITY)
148 minval
= GFC_INTEGER_16_INFINITY
;
150 minval
= GFC_INTEGER_16_HUGE
;
157 #if ! defined HAVE_BACK_ARG
158 for (n
= 0; n
< len
; n
++, src
+= delta
)
162 #if defined (GFC_INTEGER_16_QUIET_NAN)
163 for (n
= 0; n
< len
; n
++, src
+= delta
)
168 result
= (GFC_INTEGER_16
)n
+ 1;
176 for (; n
< len
; n
++, src
+= delta
)
178 if (unlikely (*src
<= minval
))
181 result
= (GFC_INTEGER_16
)n
+ 1;
185 for (; n
< len
; n
++, src
+= delta
)
187 if (unlikely (*src
< minval
))
190 result
= (GFC_INTEGER_16
) n
+ 1;
197 /* Advance to the next element. */
202 while (count
[n
] == extent
[n
])
204 /* When we get to the end of a dimension, reset it and increment
205 the next dimension. */
207 /* We could precalculate these products, but this is a less
208 frequently used path so probably not worth it. */
209 base
-= sstride
[n
] * extent
[n
];
210 dest
-= dstride
[n
] * extent
[n
];
214 /* Break out of the loop. */
229 extern void mminloc1_16_i16 (gfc_array_i16
* const restrict
,
230 gfc_array_i16
* const restrict
, const index_type
* const restrict
,
231 gfc_array_l1
* const restrict
, GFC_LOGICAL_4 back
);
232 export_proto(mminloc1_16_i16
);
235 mminloc1_16_i16 (gfc_array_i16
* const restrict retarray
,
236 gfc_array_i16
* const restrict array
,
237 const index_type
* const restrict pdim
,
238 gfc_array_l1
* const restrict mask
, GFC_LOGICAL_4 back
)
240 index_type count
[GFC_MAX_DIMENSIONS
];
241 index_type extent
[GFC_MAX_DIMENSIONS
];
242 index_type sstride
[GFC_MAX_DIMENSIONS
];
243 index_type dstride
[GFC_MAX_DIMENSIONS
];
244 index_type mstride
[GFC_MAX_DIMENSIONS
];
245 GFC_INTEGER_16
* restrict dest
;
246 const GFC_INTEGER_16
* restrict base
;
247 const GFC_LOGICAL_1
* restrict mbase
;
259 minloc1_16_i16 (retarray
, array
, pdim
, back
);
261 minloc1_16_i16 (retarray
, array
, pdim
);
267 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
270 if (unlikely (dim
< 0 || dim
> rank
))
272 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
273 "is %ld, should be between 1 and %ld",
274 (long int) dim
+ 1, (long int) rank
+ 1);
277 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
281 mbase
= mask
->base_addr
;
283 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
285 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
286 #ifdef HAVE_GFC_LOGICAL_16
290 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
292 runtime_error ("Funny sized logical array");
294 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
295 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
297 for (n
= 0; n
< dim
; n
++)
299 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
300 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
301 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
307 for (n
= dim
; n
< rank
; n
++)
309 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
310 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
311 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
317 if (retarray
->base_addr
== NULL
)
319 size_t alloc_size
, str
;
321 for (n
= 0; n
< rank
; n
++)
326 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
328 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
332 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
334 retarray
->offset
= 0;
335 retarray
->dtype
.rank
= rank
;
337 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_16
));
343 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
344 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
346 if (unlikely (compile_options
.bounds_check
))
348 bounds_ifunction_return ((array_t
*) retarray
, extent
,
349 "return value", "MINLOC");
350 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
351 "MASK argument", "MINLOC");
355 for (n
= 0; n
< rank
; n
++)
358 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
363 dest
= retarray
->base_addr
;
364 base
= array
->base_addr
;
368 const GFC_INTEGER_16
* restrict src
;
369 const GFC_LOGICAL_1
* restrict msrc
;
370 GFC_INTEGER_16 result
;
375 GFC_INTEGER_16 minval
;
376 #if defined (GFC_INTEGER_16_INFINITY)
377 minval
= GFC_INTEGER_16_INFINITY
;
379 minval
= GFC_INTEGER_16_HUGE
;
381 #if defined (GFC_INTEGER_16_QUIET_NAN)
382 GFC_INTEGER_16 result2
= 0;
385 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
390 #if defined (GFC_INTEGER_16_QUIET_NAN)
392 result2
= (GFC_INTEGER_16
)n
+ 1;
397 result
= (GFC_INTEGER_16
)n
+ 1;
402 #if defined (GFC_INTEGER_16_QUIET_NAN)
403 if (unlikely (n
>= len
))
408 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
410 if (*msrc
&& unlikely (*src
<= minval
))
413 result
= (GFC_INTEGER_16
)n
+ 1;
417 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
419 if (*msrc
&& unlikely (*src
< minval
))
422 result
= (GFC_INTEGER_16
) n
+ 1;
427 /* Advance to the next element. */
433 while (count
[n
] == extent
[n
])
435 /* When we get to the end of a dimension, reset it and increment
436 the next dimension. */
438 /* We could precalculate these products, but this is a less
439 frequently used path so probably not worth it. */
440 base
-= sstride
[n
] * extent
[n
];
441 mbase
-= mstride
[n
] * extent
[n
];
442 dest
-= dstride
[n
] * extent
[n
];
446 /* Break out of the loop. */
462 extern void sminloc1_16_i16 (gfc_array_i16
* const restrict
,
463 gfc_array_i16
* const restrict
, const index_type
* const restrict
,
464 GFC_LOGICAL_4
*, GFC_LOGICAL_4 back
);
465 export_proto(sminloc1_16_i16
);
468 sminloc1_16_i16 (gfc_array_i16
* const restrict retarray
,
469 gfc_array_i16
* const restrict array
,
470 const index_type
* const restrict pdim
,
471 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
)
473 index_type count
[GFC_MAX_DIMENSIONS
];
474 index_type extent
[GFC_MAX_DIMENSIONS
];
475 index_type dstride
[GFC_MAX_DIMENSIONS
];
476 GFC_INTEGER_16
* restrict dest
;
482 if (mask
== NULL
|| *mask
)
485 minloc1_16_i16 (retarray
, array
, pdim
, back
);
487 minloc1_16_i16 (retarray
, array
, pdim
);
491 /* Make dim zero based to avoid confusion. */
493 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
495 if (unlikely (dim
< 0 || dim
> rank
))
497 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
498 "is %ld, should be between 1 and %ld",
499 (long int) dim
+ 1, (long int) rank
+ 1);
502 for (n
= 0; n
< dim
; n
++)
504 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
510 for (n
= dim
; n
< rank
; n
++)
513 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
519 if (retarray
->base_addr
== NULL
)
521 size_t alloc_size
, str
;
523 for (n
= 0; n
< rank
; n
++)
528 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
530 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
534 retarray
->offset
= 0;
535 retarray
->dtype
.rank
= rank
;
537 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
539 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_16
));
545 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
546 runtime_error ("rank of return array incorrect in"
547 " MINLOC intrinsic: is %ld, should be %ld",
548 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
551 if (unlikely (compile_options
.bounds_check
))
553 for (n
=0; n
< rank
; n
++)
555 index_type ret_extent
;
557 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
558 if (extent
[n
] != ret_extent
)
559 runtime_error ("Incorrect extent in return value of"
560 " MINLOC intrinsic in dimension %ld:"
561 " is %ld, should be %ld", (long int) n
+ 1,
562 (long int) ret_extent
, (long int) extent
[n
]);
567 for (n
= 0; n
< rank
; n
++)
570 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
573 dest
= retarray
->base_addr
;
581 while (count
[n
] == extent
[n
])
583 /* When we get to the end of a dimension, reset it and increment
584 the next dimension. */
586 /* We could precalculate these products, but this is a less
587 frequently used path so probably not worth it. */
588 dest
-= dstride
[n
] * extent
[n
];