1 /* Implementation of the MINLOC intrinsic
2 Copyright (C) 2002-2014 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 95 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_REAL_16) && defined (HAVE_GFC_INTEGER_4)
35 extern void minloc0_4_r16 (gfc_array_i4
* const restrict retarray
,
36 gfc_array_r16
* const restrict array
);
37 export_proto(minloc0_4_r16
);
40 minloc0_4_r16 (gfc_array_i4
* const restrict retarray
,
41 gfc_array_r16
* const restrict array
)
43 index_type count
[GFC_MAX_DIMENSIONS
];
44 index_type extent
[GFC_MAX_DIMENSIONS
];
45 index_type sstride
[GFC_MAX_DIMENSIONS
];
47 const GFC_REAL_16
*base
;
48 GFC_INTEGER_4
* restrict dest
;
52 rank
= GFC_DESCRIPTOR_RANK (array
);
54 runtime_error ("Rank of array needs to be > 0");
56 if (retarray
->base_addr
== NULL
)
58 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
59 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
61 retarray
->base_addr
= xmalloc (sizeof (GFC_INTEGER_4
) * rank
);
65 if (unlikely (compile_options
.bounds_check
))
66 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
70 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
71 dest
= retarray
->base_addr
;
72 for (n
= 0; n
< rank
; n
++)
74 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
75 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
79 /* Set the return value. */
80 for (n
= 0; n
< rank
; n
++)
81 dest
[n
* dstride
] = 0;
86 base
= array
->base_addr
;
88 /* Initialize the return value. */
89 for (n
= 0; n
< rank
; n
++)
90 dest
[n
* dstride
] = 1;
94 #if defined(GFC_REAL_16_QUIET_NAN)
98 #if defined(GFC_REAL_16_INFINITY)
99 minval
= GFC_REAL_16_INFINITY
;
101 minval
= GFC_REAL_16_HUGE
;
107 /* Implementation start. */
109 #if defined(GFC_REAL_16_QUIET_NAN)
112 if (unlikely (!fast
))
120 for (n
= 0; n
< rank
; n
++)
121 dest
[n
* dstride
] = count
[n
] + 1;
126 while (++count
[0] != extent
[0]);
136 for (n
= 0; n
< rank
; n
++)
137 dest
[n
* dstride
] = count
[n
] + 1;
139 /* Implementation end. */
140 /* Advance to the next element. */
143 while (++count
[0] != extent
[0]);
147 /* When we get to the end of a dimension, reset it and increment
148 the next dimension. */
150 /* We could precalculate these products, but this is a less
151 frequently used path so probably not worth it. */
152 base
-= sstride
[n
] * extent
[n
];
156 /* Break out of the loop. */
166 while (count
[n
] == extent
[n
]);
172 extern void mminloc0_4_r16 (gfc_array_i4
* const restrict
,
173 gfc_array_r16
* const restrict
, gfc_array_l1
* const restrict
);
174 export_proto(mminloc0_4_r16
);
177 mminloc0_4_r16 (gfc_array_i4
* const restrict retarray
,
178 gfc_array_r16
* const restrict array
,
179 gfc_array_l1
* const restrict mask
)
181 index_type count
[GFC_MAX_DIMENSIONS
];
182 index_type extent
[GFC_MAX_DIMENSIONS
];
183 index_type sstride
[GFC_MAX_DIMENSIONS
];
184 index_type mstride
[GFC_MAX_DIMENSIONS
];
187 const GFC_REAL_16
*base
;
188 GFC_LOGICAL_1
*mbase
;
193 rank
= GFC_DESCRIPTOR_RANK (array
);
195 runtime_error ("Rank of array needs to be > 0");
197 if (retarray
->base_addr
== NULL
)
199 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
- 1, 1);
200 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
201 retarray
->offset
= 0;
202 retarray
->base_addr
= xmalloc (sizeof (GFC_INTEGER_4
) * rank
);
206 if (unlikely (compile_options
.bounds_check
))
209 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
211 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
212 "MASK argument", "MINLOC");
216 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
218 mbase
= mask
->base_addr
;
220 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
221 #ifdef HAVE_GFC_LOGICAL_16
225 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
227 runtime_error ("Funny sized logical array");
229 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
230 dest
= retarray
->base_addr
;
231 for (n
= 0; n
< rank
; n
++)
233 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
234 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
235 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
239 /* Set the return value. */
240 for (n
= 0; n
< rank
; n
++)
241 dest
[n
* dstride
] = 0;
246 base
= array
->base_addr
;
248 /* Initialize the return value. */
249 for (n
= 0; n
< rank
; n
++)
250 dest
[n
* dstride
] = 0;
256 #if defined(GFC_REAL_16_INFINITY)
257 minval
= GFC_REAL_16_INFINITY
;
259 minval
= GFC_REAL_16_HUGE
;
265 /* Implementation start. */
269 if (unlikely (!fast
))
275 #if defined(GFC_REAL_16_QUIET_NAN)
276 if (unlikely (dest
[0] == 0))
277 for (n
= 0; n
< rank
; n
++)
278 dest
[n
* dstride
] = count
[n
] + 1;
284 for (n
= 0; n
< rank
; n
++)
285 dest
[n
* dstride
] = count
[n
] + 1;
292 while (++count
[0] != extent
[0]);
298 if (*mbase
&& *base
< minval
)
301 for (n
= 0; n
< rank
; n
++)
302 dest
[n
* dstride
] = count
[n
] + 1;
304 /* Implementation end. */
305 /* Advance to the next element. */
309 while (++count
[0] != extent
[0]);
313 /* When we get to the end of a dimension, reset it and increment
314 the next dimension. */
316 /* We could precalculate these products, but this is a less
317 frequently used path so probably not worth it. */
318 base
-= sstride
[n
] * extent
[n
];
319 mbase
-= mstride
[n
] * extent
[n
];
323 /* Break out of the loop. */
334 while (count
[n
] == extent
[n
]);
340 extern void sminloc0_4_r16 (gfc_array_i4
* const restrict
,
341 gfc_array_r16
* const restrict
, GFC_LOGICAL_4
*);
342 export_proto(sminloc0_4_r16
);
345 sminloc0_4_r16 (gfc_array_i4
* const restrict retarray
,
346 gfc_array_r16
* const restrict array
,
347 GFC_LOGICAL_4
* mask
)
356 minloc0_4_r16 (retarray
, array
);
360 rank
= GFC_DESCRIPTOR_RANK (array
);
363 runtime_error ("Rank of array needs to be > 0");
365 if (retarray
->base_addr
== NULL
)
367 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
368 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
369 retarray
->offset
= 0;
370 retarray
->base_addr
= xmalloc (sizeof (GFC_INTEGER_4
) * rank
);
372 else if (unlikely (compile_options
.bounds_check
))
374 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
378 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
379 dest
= retarray
->base_addr
;
380 for (n
= 0; n
<rank
; n
++)
381 dest
[n
* dstride
] = 0 ;