1 /* Implementation of the MINLOC intrinsic
2 Copyright (C) 2002-2018 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_1) && defined (HAVE_GFC_INTEGER_16)
32 #define HAVE_BACK_ARG 1
35 extern void minloc1_16_i1 (gfc_array_i16
* const restrict
,
36 gfc_array_i1
* const restrict
, const index_type
* const restrict
, GFC_LOGICAL_4 back
);
37 export_proto(minloc1_16_i1
);
40 minloc1_16_i1 (gfc_array_i16
* const restrict retarray
,
41 gfc_array_i1
* 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_1
* restrict base
;
49 GFC_INTEGER_16
* restrict dest
;
61 /* Make dim zero based to avoid confusion. */
62 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
65 if (unlikely (dim
< 0 || dim
> rank
))
67 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
68 "is %ld, should be between 1 and %ld",
69 (long int) dim
+ 1, (long int) rank
+ 1);
72 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
75 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
77 for (n
= 0; n
< dim
; n
++)
79 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
80 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
85 for (n
= dim
; n
< rank
; n
++)
87 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
88 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
94 if (retarray
->base_addr
== NULL
)
96 size_t alloc_size
, str
;
98 for (n
= 0; n
< rank
; n
++)
103 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
105 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
109 retarray
->offset
= 0;
110 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
112 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
114 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_16
));
117 /* Make sure we have a zero-sized array. */
118 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
125 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
126 runtime_error ("rank of return array incorrect in"
127 " MINLOC intrinsic: is %ld, should be %ld",
128 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
131 if (unlikely (compile_options
.bounds_check
))
132 bounds_ifunction_return ((array_t
*) retarray
, extent
,
133 "return value", "MINLOC");
136 for (n
= 0; n
< rank
; n
++)
139 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
144 base
= array
->base_addr
;
145 dest
= retarray
->base_addr
;
148 while (continue_loop
)
150 const GFC_INTEGER_1
* restrict src
;
151 GFC_INTEGER_16 result
;
155 GFC_INTEGER_1 minval
;
156 #if defined (GFC_INTEGER_1_INFINITY)
157 minval
= GFC_INTEGER_1_INFINITY
;
159 minval
= GFC_INTEGER_1_HUGE
;
166 for (n
= 0; n
< len
; n
++, src
+= delta
)
169 #if defined (GFC_INTEGER_1_QUIET_NAN)
173 result
= (GFC_INTEGER_16
)n
+ 1;
177 for (; n
< len
; n
++, src
+= delta
)
183 result
= (GFC_INTEGER_16
)n
+ 1;
190 /* Advance to the next element. */
195 while (count
[n
] == extent
[n
])
197 /* When we get to the end of a dimension, reset it and increment
198 the next dimension. */
200 /* We could precalculate these products, but this is a less
201 frequently used path so probably not worth it. */
202 base
-= sstride
[n
] * extent
[n
];
203 dest
-= dstride
[n
] * extent
[n
];
207 /* Break out of the loop. */
222 extern void mminloc1_16_i1 (gfc_array_i16
* const restrict
,
223 gfc_array_i1
* const restrict
, const index_type
* const restrict
,
224 gfc_array_l1
* const restrict
, GFC_LOGICAL_4 back
);
225 export_proto(mminloc1_16_i1
);
228 mminloc1_16_i1 (gfc_array_i16
* const restrict retarray
,
229 gfc_array_i1
* const restrict array
,
230 const index_type
* const restrict pdim
,
231 gfc_array_l1
* const restrict mask
, GFC_LOGICAL_4 back
)
233 index_type count
[GFC_MAX_DIMENSIONS
];
234 index_type extent
[GFC_MAX_DIMENSIONS
];
235 index_type sstride
[GFC_MAX_DIMENSIONS
];
236 index_type dstride
[GFC_MAX_DIMENSIONS
];
237 index_type mstride
[GFC_MAX_DIMENSIONS
];
238 GFC_INTEGER_16
* restrict dest
;
239 const GFC_INTEGER_1
* restrict base
;
240 const GFC_LOGICAL_1
* restrict mbase
;
253 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
256 if (unlikely (dim
< 0 || dim
> rank
))
258 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
259 "is %ld, should be between 1 and %ld",
260 (long int) dim
+ 1, (long int) rank
+ 1);
263 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
267 mbase
= mask
->base_addr
;
269 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
271 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
272 #ifdef HAVE_GFC_LOGICAL_16
276 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
278 runtime_error ("Funny sized logical array");
280 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
281 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
283 for (n
= 0; n
< dim
; n
++)
285 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
286 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
287 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
293 for (n
= dim
; n
< rank
; n
++)
295 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
296 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
297 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
303 if (retarray
->base_addr
== NULL
)
305 size_t alloc_size
, str
;
307 for (n
= 0; n
< rank
; n
++)
312 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
314 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
318 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
320 retarray
->offset
= 0;
321 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
325 /* Make sure we have a zero-sized array. */
326 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
330 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_16
));
335 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
336 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
338 if (unlikely (compile_options
.bounds_check
))
340 bounds_ifunction_return ((array_t
*) retarray
, extent
,
341 "return value", "MINLOC");
342 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
343 "MASK argument", "MINLOC");
347 for (n
= 0; n
< rank
; n
++)
350 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
355 dest
= retarray
->base_addr
;
356 base
= array
->base_addr
;
360 const GFC_INTEGER_1
* restrict src
;
361 const GFC_LOGICAL_1
* restrict msrc
;
362 GFC_INTEGER_16 result
;
367 GFC_INTEGER_1 minval
;
368 #if defined (GFC_INTEGER_1_INFINITY)
369 minval
= GFC_INTEGER_1_INFINITY
;
371 minval
= GFC_INTEGER_1_HUGE
;
373 #if defined (GFC_INTEGER_1_QUIET_NAN)
374 GFC_INTEGER_16 result2
= 0;
377 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
382 #if defined (GFC_INTEGER_1_QUIET_NAN)
384 result2
= (GFC_INTEGER_16
)n
+ 1;
389 result
= (GFC_INTEGER_16
)n
+ 1;
394 #if defined (GFC_INTEGER_1_QUIET_NAN)
395 if (unlikely (n
>= len
))
399 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
401 if (*msrc
&& *src
< minval
)
404 result
= (GFC_INTEGER_16
)n
+ 1;
409 /* Advance to the next element. */
415 while (count
[n
] == extent
[n
])
417 /* When we get to the end of a dimension, reset it and increment
418 the next dimension. */
420 /* We could precalculate these products, but this is a less
421 frequently used path so probably not worth it. */
422 base
-= sstride
[n
] * extent
[n
];
423 mbase
-= mstride
[n
] * extent
[n
];
424 dest
-= dstride
[n
] * extent
[n
];
428 /* Break out of the loop. */
444 extern void sminloc1_16_i1 (gfc_array_i16
* const restrict
,
445 gfc_array_i1
* const restrict
, const index_type
* const restrict
,
446 GFC_LOGICAL_4
*, GFC_LOGICAL_4 back
);
447 export_proto(sminloc1_16_i1
);
450 sminloc1_16_i1 (gfc_array_i16
* const restrict retarray
,
451 gfc_array_i1
* const restrict array
,
452 const index_type
* const restrict pdim
,
453 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
)
455 index_type count
[GFC_MAX_DIMENSIONS
];
456 index_type extent
[GFC_MAX_DIMENSIONS
];
457 index_type dstride
[GFC_MAX_DIMENSIONS
];
458 GFC_INTEGER_16
* restrict dest
;
467 minloc1_16_i1 (retarray
, array
, pdim
, back
);
469 minloc1_16_i1 (retarray
, array
, pdim
);
473 /* Make dim zero based to avoid confusion. */
475 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
477 if (unlikely (dim
< 0 || dim
> rank
))
479 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
480 "is %ld, should be between 1 and %ld",
481 (long int) dim
+ 1, (long int) rank
+ 1);
484 for (n
= 0; n
< dim
; n
++)
486 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
492 for (n
= dim
; n
< rank
; n
++)
495 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
501 if (retarray
->base_addr
== NULL
)
503 size_t alloc_size
, str
;
505 for (n
= 0; n
< rank
; n
++)
510 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
512 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
516 retarray
->offset
= 0;
517 GFC_DTYPE_COPY_SETRANK(retarray
,array
,rank
);
519 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
523 /* Make sure we have a zero-sized array. */
524 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
528 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_16
));
532 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
533 runtime_error ("rank of return array incorrect in"
534 " MINLOC intrinsic: is %ld, should be %ld",
535 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
538 if (unlikely (compile_options
.bounds_check
))
540 for (n
=0; n
< rank
; n
++)
542 index_type ret_extent
;
544 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
545 if (extent
[n
] != ret_extent
)
546 runtime_error ("Incorrect extent in return value of"
547 " MINLOC intrinsic in dimension %ld:"
548 " is %ld, should be %ld", (long int) n
+ 1,
549 (long int) ret_extent
, (long int) extent
[n
]);
554 for (n
= 0; n
< rank
; n
++)
557 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
560 dest
= retarray
->base_addr
;
568 while (count
[n
] == extent
[n
])
570 /* When we get to the end of a dimension, reset it and increment
571 the next dimension. */
573 /* We could precalculate these products, but this is a less
574 frequently used path so probably not worth it. */
575 dest
-= dstride
[n
] * extent
[n
];