1 /* Implementation of the MINLOC intrinsic
2 Copyright (C) 2002-2015 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"
32 #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16)
35 extern void minloc1_16_i16 (gfc_array_i16
* const restrict
,
36 gfc_array_i16
* const restrict
, const index_type
* const restrict
);
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
)
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. */
59 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
61 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
64 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
66 for (n
= 0; n
< dim
; n
++)
68 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
69 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
74 for (n
= dim
; n
< rank
; n
++)
76 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
77 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
83 if (retarray
->base_addr
== NULL
)
85 size_t alloc_size
, str
;
87 for (n
= 0; n
< rank
; n
++)
92 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
94 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
99 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
101 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
103 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_16
));
106 /* Make sure we have a zero-sized array. */
107 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
114 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
115 runtime_error ("rank of return array incorrect in"
116 " MINLOC intrinsic: is %ld, should be %ld",
117 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
120 if (unlikely (compile_options
.bounds_check
))
121 bounds_ifunction_return ((array_t
*) retarray
, extent
,
122 "return value", "MINLOC");
125 for (n
= 0; n
< rank
; n
++)
128 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
133 base
= array
->base_addr
;
134 dest
= retarray
->base_addr
;
137 while (continue_loop
)
139 const GFC_INTEGER_16
* restrict src
;
140 GFC_INTEGER_16 result
;
144 GFC_INTEGER_16 minval
;
145 #if defined (GFC_INTEGER_16_INFINITY)
146 minval
= GFC_INTEGER_16_INFINITY
;
148 minval
= GFC_INTEGER_16_HUGE
;
155 for (n
= 0; n
< len
; n
++, src
+= delta
)
158 #if defined (GFC_INTEGER_16_QUIET_NAN)
162 result
= (GFC_INTEGER_16
)n
+ 1;
166 for (; n
< len
; n
++, src
+= delta
)
172 result
= (GFC_INTEGER_16
)n
+ 1;
179 /* Advance to the next element. */
184 while (count
[n
] == extent
[n
])
186 /* When we get to the end of a dimension, reset it and increment
187 the next dimension. */
189 /* We could precalculate these products, but this is a less
190 frequently used path so probably not worth it. */
191 base
-= sstride
[n
] * extent
[n
];
192 dest
-= dstride
[n
] * extent
[n
];
196 /* Break out of the look. */
211 extern void mminloc1_16_i16 (gfc_array_i16
* const restrict
,
212 gfc_array_i16
* const restrict
, const index_type
* const restrict
,
213 gfc_array_l1
* const restrict
);
214 export_proto(mminloc1_16_i16
);
217 mminloc1_16_i16 (gfc_array_i16
* const restrict retarray
,
218 gfc_array_i16
* const restrict array
,
219 const index_type
* const restrict pdim
,
220 gfc_array_l1
* const restrict mask
)
222 index_type count
[GFC_MAX_DIMENSIONS
];
223 index_type extent
[GFC_MAX_DIMENSIONS
];
224 index_type sstride
[GFC_MAX_DIMENSIONS
];
225 index_type dstride
[GFC_MAX_DIMENSIONS
];
226 index_type mstride
[GFC_MAX_DIMENSIONS
];
227 GFC_INTEGER_16
* restrict dest
;
228 const GFC_INTEGER_16
* restrict base
;
229 const GFC_LOGICAL_1
* restrict mbase
;
239 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
241 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
245 mbase
= mask
->base_addr
;
247 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
249 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
250 #ifdef HAVE_GFC_LOGICAL_16
254 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
256 runtime_error ("Funny sized logical array");
258 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
259 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
261 for (n
= 0; n
< dim
; n
++)
263 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
264 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
265 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
271 for (n
= dim
; n
< rank
; n
++)
273 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
274 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
275 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
281 if (retarray
->base_addr
== NULL
)
283 size_t alloc_size
, str
;
285 for (n
= 0; n
< rank
; n
++)
290 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
292 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
296 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
298 retarray
->offset
= 0;
299 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
303 /* Make sure we have a zero-sized array. */
304 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
308 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_16
));
313 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
314 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
316 if (unlikely (compile_options
.bounds_check
))
318 bounds_ifunction_return ((array_t
*) retarray
, extent
,
319 "return value", "MINLOC");
320 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
321 "MASK argument", "MINLOC");
325 for (n
= 0; n
< rank
; n
++)
328 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
333 dest
= retarray
->base_addr
;
334 base
= array
->base_addr
;
338 const GFC_INTEGER_16
* restrict src
;
339 const GFC_LOGICAL_1
* restrict msrc
;
340 GFC_INTEGER_16 result
;
345 GFC_INTEGER_16 minval
;
346 #if defined (GFC_INTEGER_16_INFINITY)
347 minval
= GFC_INTEGER_16_INFINITY
;
349 minval
= GFC_INTEGER_16_HUGE
;
351 #if defined (GFC_INTEGER_16_QUIET_NAN)
352 GFC_INTEGER_16 result2
= 0;
355 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
360 #if defined (GFC_INTEGER_16_QUIET_NAN)
362 result2
= (GFC_INTEGER_16
)n
+ 1;
367 result
= (GFC_INTEGER_16
)n
+ 1;
372 #if defined (GFC_INTEGER_16_QUIET_NAN)
373 if (unlikely (n
>= len
))
377 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
379 if (*msrc
&& *src
< minval
)
382 result
= (GFC_INTEGER_16
)n
+ 1;
387 /* Advance to the next element. */
393 while (count
[n
] == extent
[n
])
395 /* When we get to the end of a dimension, reset it and increment
396 the next dimension. */
398 /* We could precalculate these products, but this is a less
399 frequently used path so probably not worth it. */
400 base
-= sstride
[n
] * extent
[n
];
401 mbase
-= mstride
[n
] * extent
[n
];
402 dest
-= dstride
[n
] * extent
[n
];
406 /* Break out of the look. */
422 extern void sminloc1_16_i16 (gfc_array_i16
* const restrict
,
423 gfc_array_i16
* const restrict
, const index_type
* const restrict
,
425 export_proto(sminloc1_16_i16
);
428 sminloc1_16_i16 (gfc_array_i16
* const restrict retarray
,
429 gfc_array_i16
* const restrict array
,
430 const index_type
* const restrict pdim
,
431 GFC_LOGICAL_4
* mask
)
433 index_type count
[GFC_MAX_DIMENSIONS
];
434 index_type extent
[GFC_MAX_DIMENSIONS
];
435 index_type dstride
[GFC_MAX_DIMENSIONS
];
436 GFC_INTEGER_16
* restrict dest
;
444 minloc1_16_i16 (retarray
, array
, pdim
);
447 /* Make dim zero based to avoid confusion. */
449 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
451 for (n
= 0; n
< dim
; n
++)
453 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
459 for (n
= dim
; n
< rank
; n
++)
462 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
468 if (retarray
->base_addr
== NULL
)
470 size_t alloc_size
, str
;
472 for (n
= 0; n
< rank
; n
++)
477 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
479 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
483 retarray
->offset
= 0;
484 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
486 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
490 /* Make sure we have a zero-sized array. */
491 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
495 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_16
));
499 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
500 runtime_error ("rank of return array incorrect in"
501 " MINLOC intrinsic: is %ld, should be %ld",
502 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
505 if (unlikely (compile_options
.bounds_check
))
507 for (n
=0; n
< rank
; n
++)
509 index_type ret_extent
;
511 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
512 if (extent
[n
] != ret_extent
)
513 runtime_error ("Incorrect extent in return value of"
514 " MINLOC intrinsic in dimension %ld:"
515 " is %ld, should be %ld", (long int) n
+ 1,
516 (long int) ret_extent
, (long int) extent
[n
]);
521 for (n
= 0; n
< rank
; n
++)
524 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
527 dest
= retarray
->base_addr
;
535 while (count
[n
] == extent
[n
])
537 /* When we get to the end of a dimension, reset it and increment
538 the next dimension. */
540 /* We could precalculate these products, but this is a less
541 frequently used path so probably not worth it. */
542 dest
-= dstride
[n
] * extent
[n
];