1 /* Implementation of the MINLOC intrinsic
2 Copyright 2002, 2007, 2009, 2010 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_4) && defined (HAVE_GFC_INTEGER_16)
35 extern void minloc1_16_i4 (gfc_array_i16
* const restrict
,
36 gfc_array_i4
* const restrict
, const index_type
* const restrict
);
37 export_proto(minloc1_16_i4
);
40 minloc1_16_i4 (gfc_array_i16
* const restrict retarray
,
41 gfc_array_i4
* 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_4
* 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
->data
== 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
= sizeof (GFC_INTEGER_16
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
106 /* Make sure we have a zero-sized array. */
107 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
112 retarray
->data
= internal_malloc_size (alloc_size
);
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
);
136 dest
= retarray
->data
;
139 while (continue_loop
)
141 const GFC_INTEGER_4
* restrict src
;
142 GFC_INTEGER_16 result
;
146 GFC_INTEGER_4 minval
;
147 #if defined (GFC_INTEGER_4_INFINITY)
148 minval
= GFC_INTEGER_4_INFINITY
;
150 minval
= GFC_INTEGER_4_HUGE
;
157 for (n
= 0; n
< len
; n
++, src
+= delta
)
160 #if defined (GFC_INTEGER_4_QUIET_NAN)
164 result
= (GFC_INTEGER_16
)n
+ 1;
168 for (; n
< len
; n
++, src
+= delta
)
174 result
= (GFC_INTEGER_16
)n
+ 1;
181 /* Advance to the next element. */
186 while (count
[n
] == extent
[n
])
188 /* When we get to the end of a dimension, reset it and increment
189 the next dimension. */
191 /* We could precalculate these products, but this is a less
192 frequently used path so probably not worth it. */
193 base
-= sstride
[n
] * extent
[n
];
194 dest
-= dstride
[n
] * extent
[n
];
198 /* Break out of the look. */
213 extern void mminloc1_16_i4 (gfc_array_i16
* const restrict
,
214 gfc_array_i4
* const restrict
, const index_type
* const restrict
,
215 gfc_array_l1
* const restrict
);
216 export_proto(mminloc1_16_i4
);
219 mminloc1_16_i4 (gfc_array_i16
* const restrict retarray
,
220 gfc_array_i4
* const restrict array
,
221 const index_type
* const restrict pdim
,
222 gfc_array_l1
* const restrict mask
)
224 index_type count
[GFC_MAX_DIMENSIONS
];
225 index_type extent
[GFC_MAX_DIMENSIONS
];
226 index_type sstride
[GFC_MAX_DIMENSIONS
];
227 index_type dstride
[GFC_MAX_DIMENSIONS
];
228 index_type mstride
[GFC_MAX_DIMENSIONS
];
229 GFC_INTEGER_16
* restrict dest
;
230 const GFC_INTEGER_4
* restrict base
;
231 const GFC_LOGICAL_1
* restrict mbase
;
241 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
243 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
249 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
251 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
252 #ifdef HAVE_GFC_LOGICAL_16
256 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
258 runtime_error ("Funny sized logical array");
260 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
261 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
263 for (n
= 0; n
< dim
; n
++)
265 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
266 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
267 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
273 for (n
= dim
; n
< rank
; n
++)
275 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
276 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
277 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
283 if (retarray
->data
== NULL
)
285 size_t alloc_size
, str
;
287 for (n
= 0; n
< rank
; n
++)
292 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
294 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
298 alloc_size
= sizeof (GFC_INTEGER_16
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
301 retarray
->offset
= 0;
302 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
306 /* Make sure we have a zero-sized array. */
307 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
311 retarray
->data
= internal_malloc_size (alloc_size
);
316 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
317 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
319 if (unlikely (compile_options
.bounds_check
))
321 bounds_ifunction_return ((array_t
*) retarray
, extent
,
322 "return value", "MINLOC");
323 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
324 "MASK argument", "MINLOC");
328 for (n
= 0; n
< rank
; n
++)
331 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
336 dest
= retarray
->data
;
341 const GFC_INTEGER_4
* restrict src
;
342 const GFC_LOGICAL_1
* restrict msrc
;
343 GFC_INTEGER_16 result
;
348 GFC_INTEGER_4 minval
;
349 #if defined (GFC_INTEGER_4_INFINITY)
350 minval
= GFC_INTEGER_4_INFINITY
;
352 minval
= GFC_INTEGER_4_HUGE
;
354 #if defined (GFC_INTEGER_4_QUIET_NAN)
355 GFC_INTEGER_16 result2
= 0;
362 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
367 #if defined (GFC_INTEGER_4_QUIET_NAN)
369 result2
= (GFC_INTEGER_16
)n
+ 1;
374 result
= (GFC_INTEGER_16
)n
+ 1;
379 #if defined (GFC_INTEGER_4_QUIET_NAN)
380 if (unlikely (n
>= len
))
384 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
386 if (*msrc
&& *src
< minval
)
389 result
= (GFC_INTEGER_16
)n
+ 1;
395 /* Advance to the next element. */
401 while (count
[n
] == extent
[n
])
403 /* When we get to the end of a dimension, reset it and increment
404 the next dimension. */
406 /* We could precalculate these products, but this is a less
407 frequently used path so probably not worth it. */
408 base
-= sstride
[n
] * extent
[n
];
409 mbase
-= mstride
[n
] * extent
[n
];
410 dest
-= dstride
[n
] * extent
[n
];
414 /* Break out of the look. */
430 extern void sminloc1_16_i4 (gfc_array_i16
* const restrict
,
431 gfc_array_i4
* const restrict
, const index_type
* const restrict
,
433 export_proto(sminloc1_16_i4
);
436 sminloc1_16_i4 (gfc_array_i16
* const restrict retarray
,
437 gfc_array_i4
* const restrict array
,
438 const index_type
* const restrict pdim
,
439 GFC_LOGICAL_4
* mask
)
441 index_type count
[GFC_MAX_DIMENSIONS
];
442 index_type extent
[GFC_MAX_DIMENSIONS
];
443 index_type dstride
[GFC_MAX_DIMENSIONS
];
444 GFC_INTEGER_16
* restrict dest
;
452 minloc1_16_i4 (retarray
, array
, pdim
);
455 /* Make dim zero based to avoid confusion. */
457 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
459 for (n
= 0; n
< dim
; n
++)
461 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
467 for (n
= dim
; n
< rank
; n
++)
470 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
476 if (retarray
->data
== NULL
)
478 size_t alloc_size
, str
;
480 for (n
= 0; n
< rank
; n
++)
485 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
487 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
491 retarray
->offset
= 0;
492 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
494 alloc_size
= sizeof (GFC_INTEGER_16
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
499 /* Make sure we have a zero-sized array. */
500 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
504 retarray
->data
= internal_malloc_size (alloc_size
);
508 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
509 runtime_error ("rank of return array incorrect in"
510 " MINLOC intrinsic: is %ld, should be %ld",
511 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
514 if (unlikely (compile_options
.bounds_check
))
516 for (n
=0; n
< rank
; n
++)
518 index_type ret_extent
;
520 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
521 if (extent
[n
] != ret_extent
)
522 runtime_error ("Incorrect extent in return value of"
523 " MINLOC intrinsic in dimension %ld:"
524 " is %ld, should be %ld", (long int) n
+ 1,
525 (long int) ret_extent
, (long int) extent
[n
]);
530 for (n
= 0; n
< rank
; n
++)
533 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
536 dest
= retarray
->data
;
544 while (count
[n
] == extent
[n
])
546 /* When we get to the end of a dimension, reset it and increment
547 the next dimension. */
549 /* We could precalculate these products, but this is a less
550 frequently used path so probably not worth it. */
551 dest
-= dstride
[n
] * extent
[n
];