1 /* Implementation of the MINLOC intrinsic
2 Copyright (C) 2002-2021 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_8)
32 #define HAVE_BACK_ARG 1
35 extern void minloc1_8_i4 (gfc_array_i8
* const restrict
,
36 gfc_array_i4
* const restrict
, const index_type
* const restrict
, GFC_LOGICAL_4 back
);
37 export_proto(minloc1_8_i4
);
40 minloc1_8_i4 (gfc_array_i8
* 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_8
* 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_8
));
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 " MINLOC 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", "MINLOC");
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_8 result
;
151 GFC_INTEGER_4 minval
;
152 #if defined (GFC_INTEGER_4_INFINITY)
153 minval
= GFC_INTEGER_4_INFINITY
;
155 minval
= GFC_INTEGER_4_HUGE
;
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_8
)n
+ 1;
181 for (; n
< len
; n
++, src
+= delta
)
183 if (unlikely (*src
<= minval
))
186 result
= (GFC_INTEGER_8
)n
+ 1;
190 for (; n
< len
; n
++, src
+= delta
)
192 if (unlikely (*src
< minval
))
195 result
= (GFC_INTEGER_8
) n
+ 1;
202 /* Advance to the next element. */
207 while (count
[n
] == extent
[n
])
209 /* When we get to the end of a dimension, reset it and increment
210 the next dimension. */
212 /* We could precalculate these products, but this is a less
213 frequently used path so probably not worth it. */
214 base
-= sstride
[n
] * extent
[n
];
215 dest
-= dstride
[n
] * extent
[n
];
219 /* Break out of the loop. */
234 extern void mminloc1_8_i4 (gfc_array_i8
* const restrict
,
235 gfc_array_i4
* const restrict
, const index_type
* const restrict
,
236 gfc_array_l1
* const restrict
, GFC_LOGICAL_4 back
);
237 export_proto(mminloc1_8_i4
);
240 mminloc1_8_i4 (gfc_array_i8
* const restrict retarray
,
241 gfc_array_i4
* const restrict array
,
242 const index_type
* const restrict pdim
,
243 gfc_array_l1
* const restrict mask
, GFC_LOGICAL_4 back
)
245 index_type count
[GFC_MAX_DIMENSIONS
];
246 index_type extent
[GFC_MAX_DIMENSIONS
];
247 index_type sstride
[GFC_MAX_DIMENSIONS
];
248 index_type dstride
[GFC_MAX_DIMENSIONS
];
249 index_type mstride
[GFC_MAX_DIMENSIONS
];
250 GFC_INTEGER_8
* restrict dest
;
251 const GFC_INTEGER_4
* restrict base
;
252 const GFC_LOGICAL_1
* restrict mbase
;
264 minloc1_8_i4 (retarray
, array
, pdim
, back
);
266 minloc1_8_i4 (retarray
, array
, pdim
);
272 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
275 if (unlikely (dim
< 0 || dim
> rank
))
277 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
278 "is %ld, should be between 1 and %ld",
279 (long int) dim
+ 1, (long int) rank
+ 1);
282 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
286 mbase
= mask
->base_addr
;
288 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
290 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
291 #ifdef HAVE_GFC_LOGICAL_16
295 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
297 runtime_error ("Funny sized logical array");
299 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
300 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
302 for (n
= 0; n
< dim
; n
++)
304 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
305 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
306 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
312 for (n
= dim
; n
< rank
; n
++)
314 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
315 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
316 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
322 if (retarray
->base_addr
== NULL
)
324 size_t alloc_size
, str
;
326 for (n
= 0; n
< rank
; n
++)
331 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
333 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
337 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
339 retarray
->offset
= 0;
340 retarray
->dtype
.rank
= rank
;
344 /* Make sure we have a zero-sized array. */
345 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
349 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_8
));
354 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
355 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
357 if (unlikely (compile_options
.bounds_check
))
359 bounds_ifunction_return ((array_t
*) retarray
, extent
,
360 "return value", "MINLOC");
361 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
362 "MASK argument", "MINLOC");
366 for (n
= 0; n
< rank
; n
++)
369 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
374 dest
= retarray
->base_addr
;
375 base
= array
->base_addr
;
379 const GFC_INTEGER_4
* restrict src
;
380 const GFC_LOGICAL_1
* restrict msrc
;
381 GFC_INTEGER_8 result
;
386 GFC_INTEGER_4 minval
;
387 #if defined (GFC_INTEGER_4_INFINITY)
388 minval
= GFC_INTEGER_4_INFINITY
;
390 minval
= GFC_INTEGER_4_HUGE
;
392 #if defined (GFC_INTEGER_4_QUIET_NAN)
393 GFC_INTEGER_8 result2
= 0;
396 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
401 #if defined (GFC_INTEGER_4_QUIET_NAN)
403 result2
= (GFC_INTEGER_8
)n
+ 1;
408 result
= (GFC_INTEGER_8
)n
+ 1;
413 #if defined (GFC_INTEGER_4_QUIET_NAN)
414 if (unlikely (n
>= len
))
419 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
421 if (*msrc
&& unlikely (*src
<= minval
))
424 result
= (GFC_INTEGER_8
)n
+ 1;
428 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
430 if (*msrc
&& unlikely (*src
< minval
))
433 result
= (GFC_INTEGER_8
) n
+ 1;
438 /* Advance to the next element. */
444 while (count
[n
] == extent
[n
])
446 /* When we get to the end of a dimension, reset it and increment
447 the next dimension. */
449 /* We could precalculate these products, but this is a less
450 frequently used path so probably not worth it. */
451 base
-= sstride
[n
] * extent
[n
];
452 mbase
-= mstride
[n
] * extent
[n
];
453 dest
-= dstride
[n
] * extent
[n
];
457 /* Break out of the loop. */
473 extern void sminloc1_8_i4 (gfc_array_i8
* const restrict
,
474 gfc_array_i4
* const restrict
, const index_type
* const restrict
,
475 GFC_LOGICAL_4
*, GFC_LOGICAL_4 back
);
476 export_proto(sminloc1_8_i4
);
479 sminloc1_8_i4 (gfc_array_i8
* const restrict retarray
,
480 gfc_array_i4
* const restrict array
,
481 const index_type
* const restrict pdim
,
482 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
)
484 index_type count
[GFC_MAX_DIMENSIONS
];
485 index_type extent
[GFC_MAX_DIMENSIONS
];
486 index_type dstride
[GFC_MAX_DIMENSIONS
];
487 GFC_INTEGER_8
* restrict dest
;
493 if (mask
== NULL
|| *mask
)
496 minloc1_8_i4 (retarray
, array
, pdim
, back
);
498 minloc1_8_i4 (retarray
, array
, pdim
);
502 /* Make dim zero based to avoid confusion. */
504 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
506 if (unlikely (dim
< 0 || dim
> rank
))
508 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
509 "is %ld, should be between 1 and %ld",
510 (long int) dim
+ 1, (long int) rank
+ 1);
513 for (n
= 0; n
< dim
; n
++)
515 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
521 for (n
= dim
; n
< rank
; n
++)
524 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
530 if (retarray
->base_addr
== NULL
)
532 size_t alloc_size
, str
;
534 for (n
= 0; n
< rank
; n
++)
539 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
541 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
545 retarray
->offset
= 0;
546 retarray
->dtype
.rank
= rank
;
548 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
552 /* Make sure we have a zero-sized array. */
553 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
557 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_8
));
561 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
562 runtime_error ("rank of return array incorrect in"
563 " MINLOC intrinsic: is %ld, should be %ld",
564 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
567 if (unlikely (compile_options
.bounds_check
))
569 for (n
=0; n
< rank
; n
++)
571 index_type ret_extent
;
573 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
574 if (extent
[n
] != ret_extent
)
575 runtime_error ("Incorrect extent in return value of"
576 " MINLOC intrinsic in dimension %ld:"
577 " is %ld, should be %ld", (long int) n
+ 1,
578 (long int) ret_extent
, (long int) extent
[n
]);
583 for (n
= 0; n
< rank
; n
++)
586 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
589 dest
= retarray
->base_addr
;
597 while (count
[n
] == extent
[n
])
599 /* When we get to the end of a dimension, reset it and increment
600 the next dimension. */
602 /* We could precalculate these products, but this is a less
603 frequently used path so probably not worth it. */
604 dest
-= dstride
[n
] * extent
[n
];