]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/generated/minloc0_4_r4.c
1 /* Implementation of the MINLOC intrinsic
2 Copyright (C) 2002-2016 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"
31 #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4)
34 extern void minloc0_4_r4 (gfc_array_i4
* const restrict retarray
,
35 gfc_array_r4
* const restrict array
);
36 export_proto(minloc0_4_r4
);
39 minloc0_4_r4 (gfc_array_i4
* const restrict retarray
,
40 gfc_array_r4
* const restrict array
)
42 index_type count
[GFC_MAX_DIMENSIONS
];
43 index_type extent
[GFC_MAX_DIMENSIONS
];
44 index_type sstride
[GFC_MAX_DIMENSIONS
];
46 const GFC_REAL_4
*base
;
47 GFC_INTEGER_4
* restrict dest
;
51 rank
= GFC_DESCRIPTOR_RANK (array
);
53 runtime_error ("Rank of array needs to be > 0");
55 if (retarray
->base_addr
== NULL
)
57 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
58 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
60 retarray
->base_addr
= xmallocarray (rank
, sizeof (GFC_INTEGER_4
));
64 if (unlikely (compile_options
.bounds_check
))
65 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
69 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
70 dest
= retarray
->base_addr
;
71 for (n
= 0; n
< rank
; n
++)
73 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
74 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
78 /* Set the return value. */
79 for (n
= 0; n
< rank
; n
++)
80 dest
[n
* dstride
] = 0;
85 base
= array
->base_addr
;
87 /* Initialize the return value. */
88 for (n
= 0; n
< rank
; n
++)
89 dest
[n
* dstride
] = 1;
93 #if defined(GFC_REAL_4_QUIET_NAN)
97 #if defined(GFC_REAL_4_INFINITY)
98 minval
= GFC_REAL_4_INFINITY
;
100 minval
= GFC_REAL_4_HUGE
;
106 /* Implementation start. */
108 #if defined(GFC_REAL_4_QUIET_NAN)
111 if (unlikely (!fast
))
119 for (n
= 0; n
< rank
; n
++)
120 dest
[n
* dstride
] = count
[n
] + 1;
125 while (++count
[0] != extent
[0]);
135 for (n
= 0; n
< rank
; n
++)
136 dest
[n
* dstride
] = count
[n
] + 1;
138 /* Implementation end. */
139 /* Advance to the next element. */
142 while (++count
[0] != extent
[0]);
146 /* When we get to the end of a dimension, reset it and increment
147 the next dimension. */
149 /* We could precalculate these products, but this is a less
150 frequently used path so probably not worth it. */
151 base
-= sstride
[n
] * extent
[n
];
155 /* Break out of the loop. */
165 while (count
[n
] == extent
[n
]);
171 extern void mminloc0_4_r4 (gfc_array_i4
* const restrict
,
172 gfc_array_r4
* const restrict
, gfc_array_l1
* const restrict
);
173 export_proto(mminloc0_4_r4
);
176 mminloc0_4_r4 (gfc_array_i4
* const restrict retarray
,
177 gfc_array_r4
* const restrict array
,
178 gfc_array_l1
* const restrict mask
)
180 index_type count
[GFC_MAX_DIMENSIONS
];
181 index_type extent
[GFC_MAX_DIMENSIONS
];
182 index_type sstride
[GFC_MAX_DIMENSIONS
];
183 index_type mstride
[GFC_MAX_DIMENSIONS
];
186 const GFC_REAL_4
*base
;
187 GFC_LOGICAL_1
*mbase
;
192 rank
= GFC_DESCRIPTOR_RANK (array
);
194 runtime_error ("Rank of array needs to be > 0");
196 if (retarray
->base_addr
== NULL
)
198 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
- 1, 1);
199 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
200 retarray
->offset
= 0;
201 retarray
->base_addr
= xmallocarray (rank
, sizeof (GFC_INTEGER_4
));
205 if (unlikely (compile_options
.bounds_check
))
208 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
210 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
211 "MASK argument", "MINLOC");
215 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
217 mbase
= mask
->base_addr
;
219 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
220 #ifdef HAVE_GFC_LOGICAL_16
224 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
226 runtime_error ("Funny sized logical array");
228 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
229 dest
= retarray
->base_addr
;
230 for (n
= 0; n
< rank
; n
++)
232 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
233 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
234 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
238 /* Set the return value. */
239 for (n
= 0; n
< rank
; n
++)
240 dest
[n
* dstride
] = 0;
245 base
= array
->base_addr
;
247 /* Initialize the return value. */
248 for (n
= 0; n
< rank
; n
++)
249 dest
[n
* dstride
] = 0;
255 #if defined(GFC_REAL_4_INFINITY)
256 minval
= GFC_REAL_4_INFINITY
;
258 minval
= GFC_REAL_4_HUGE
;
264 /* Implementation start. */
268 if (unlikely (!fast
))
274 #if defined(GFC_REAL_4_QUIET_NAN)
275 if (unlikely (dest
[0] == 0))
276 for (n
= 0; n
< rank
; n
++)
277 dest
[n
* dstride
] = count
[n
] + 1;
283 for (n
= 0; n
< rank
; n
++)
284 dest
[n
* dstride
] = count
[n
] + 1;
291 while (++count
[0] != extent
[0]);
297 if (*mbase
&& *base
< minval
)
300 for (n
= 0; n
< rank
; n
++)
301 dest
[n
* dstride
] = count
[n
] + 1;
303 /* Implementation end. */
304 /* Advance to the next element. */
308 while (++count
[0] != extent
[0]);
312 /* When we get to the end of a dimension, reset it and increment
313 the next dimension. */
315 /* We could precalculate these products, but this is a less
316 frequently used path so probably not worth it. */
317 base
-= sstride
[n
] * extent
[n
];
318 mbase
-= mstride
[n
] * extent
[n
];
322 /* Break out of the loop. */
333 while (count
[n
] == extent
[n
]);
339 extern void sminloc0_4_r4 (gfc_array_i4
* const restrict
,
340 gfc_array_r4
* const restrict
, GFC_LOGICAL_4
*);
341 export_proto(sminloc0_4_r4
);
344 sminloc0_4_r4 (gfc_array_i4
* const restrict retarray
,
345 gfc_array_r4
* const restrict array
,
346 GFC_LOGICAL_4
* mask
)
355 minloc0_4_r4 (retarray
, array
);
359 rank
= GFC_DESCRIPTOR_RANK (array
);
362 runtime_error ("Rank of array needs to be > 0");
364 if (retarray
->base_addr
== NULL
)
366 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
367 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
368 retarray
->offset
= 0;
369 retarray
->base_addr
= xmallocarray (rank
, sizeof (GFC_INTEGER_4
));
371 else if (unlikely (compile_options
.bounds_check
))
373 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
377 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
378 dest
= retarray
->base_addr
;
379 for (n
= 0; n
<rank
; n
++)
380 dest
[n
* dstride
] = 0 ;