2 /* Implementation of the FINDLOC intrinsic
3 Copyright (C) 2018-2022 Free Software Foundation, Inc.
4 Contributed by Thomas König <tk@tkoenig.net>
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or
9 modify it under the terms of the GNU General Public
10 License as published by the Free Software Foundation; either
11 version 3 of the License, or (at your option) any later version.
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
27 #include "libgfortran.h"
30 #if defined (HAVE_GFC_REAL_4)
31 extern void findloc0_r4 (gfc_array_index_type
* const restrict retarray
,
32 gfc_array_r4
* const restrict array
, GFC_REAL_4 value
,
34 export_proto(findloc0_r4
);
37 findloc0_r4 (gfc_array_index_type
* const restrict retarray
,
38 gfc_array_r4
* const restrict array
, GFC_REAL_4 value
,
41 index_type count
[GFC_MAX_DIMENSIONS
];
42 index_type extent
[GFC_MAX_DIMENSIONS
];
43 index_type sstride
[GFC_MAX_DIMENSIONS
];
45 const GFC_REAL_4
*base
;
46 index_type
* 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
.rank
= 1;
60 retarray
->base_addr
= xmallocarray (rank
, sizeof (index_type
));
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
;
72 /* Set the return value. */
73 for (n
= 0; n
< rank
; n
++)
74 dest
[n
* dstride
] = 0;
77 for (n
= 0; n
< rank
; n
++)
79 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
80 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
86 for (n
= 0; n
< rank
; n
++)
91 base
= array
->base_addr
+ (sz
- 1) * 1;
97 if (unlikely(*base
== value
))
99 for (n
= 0; n
< rank
; n
++)
100 dest
[n
* dstride
] = extent
[n
] - count
[n
];
104 base
-= sstride
[0] * 1;
105 } while(++count
[0] != extent
[0]);
110 /* When we get to the end of a dimension, reset it and increment
111 the next dimension. */
113 /* We could precalculate these products, but this is a less
114 frequently used path so probably not worth it. */
115 base
+= sstride
[n
] * extent
[n
] * 1;
122 base
-= sstride
[n
] * 1;
124 } while (count
[n
] == extent
[n
]);
129 base
= array
->base_addr
;
134 if (unlikely(*base
== value
))
136 for (n
= 0; n
< rank
; n
++)
137 dest
[n
* dstride
] = count
[n
] + 1;
141 base
+= sstride
[0] * 1;
142 } 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
] * 1;
159 base
+= sstride
[n
] * 1;
161 } while (count
[n
] == extent
[n
]);
167 extern void mfindloc0_r4 (gfc_array_index_type
* const restrict retarray
,
168 gfc_array_r4
* const restrict array
, GFC_REAL_4 value
,
169 gfc_array_l1
*const restrict
, GFC_LOGICAL_4
);
170 export_proto(mfindloc0_r4
);
173 mfindloc0_r4 (gfc_array_index_type
* const restrict retarray
,
174 gfc_array_r4
* const restrict array
, GFC_REAL_4 value
,
175 gfc_array_l1
*const restrict mask
, GFC_LOGICAL_4 back
)
177 index_type count
[GFC_MAX_DIMENSIONS
];
178 index_type extent
[GFC_MAX_DIMENSIONS
];
179 index_type sstride
[GFC_MAX_DIMENSIONS
];
180 index_type mstride
[GFC_MAX_DIMENSIONS
];
182 const GFC_REAL_4
*base
;
183 index_type
* restrict dest
;
184 GFC_LOGICAL_1
*mbase
;
190 rank
= GFC_DESCRIPTOR_RANK (array
);
192 runtime_error ("Rank of array needs to be > 0");
194 if (retarray
->base_addr
== NULL
)
196 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
197 retarray
->dtype
.rank
= 1;
198 retarray
->offset
= 0;
199 retarray
->base_addr
= xmallocarray (rank
, sizeof (index_type
));
203 if (unlikely (compile_options
.bounds_check
))
205 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
207 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
208 "MASK argument", "FINDLOC");
212 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
214 mbase
= mask
->base_addr
;
216 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
217 #ifdef HAVE_GFC_LOGICAL_16
221 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
223 internal_error (NULL
, "Funny sized logical array");
225 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
226 dest
= retarray
->base_addr
;
228 /* Set the return value. */
229 for (n
= 0; n
< rank
; n
++)
230 dest
[n
* dstride
] = 0;
233 for (n
= 0; n
< rank
; n
++)
235 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
236 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
237 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
243 for (n
= 0; n
< rank
; n
++)
248 base
= array
->base_addr
+ (sz
- 1) * 1;
249 mbase
= mbase
+ (sz
- 1) * mask_kind
;
254 if (unlikely(*mbase
&& *base
== value
))
256 for (n
= 0; n
< rank
; n
++)
257 dest
[n
* dstride
] = extent
[n
] - count
[n
];
261 base
-= sstride
[0] * 1;
263 } while(++count
[0] != extent
[0]);
268 /* When we get to the end of a dimension, reset it and increment
269 the next dimension. */
271 /* We could precalculate these products, but this is a less
272 frequently used path so probably not worth it. */
273 base
+= sstride
[n
] * extent
[n
] * 1;
274 mbase
-= mstride
[n
] * extent
[n
];
281 base
-= sstride
[n
] * 1;
284 } while (count
[n
] == extent
[n
]);
289 base
= array
->base_addr
;
294 if (unlikely(*mbase
&& *base
== value
))
296 for (n
= 0; n
< rank
; n
++)
297 dest
[n
* dstride
] = count
[n
] + 1;
301 base
+= sstride
[0] * 1;
303 } while(++count
[0] != extent
[0]);
308 /* When we get to the end of a dimension, reset it and increment
309 the next dimension. */
311 /* We could precalculate these products, but this is a less
312 frequently used path so probably not worth it. */
313 base
-= sstride
[n
] * extent
[n
] * 1;
314 mbase
-= mstride
[n
] * extent
[n
];
321 base
+= sstride
[n
]* 1;
324 } while (count
[n
] == extent
[n
]);
330 extern void sfindloc0_r4 (gfc_array_index_type
* const restrict retarray
,
331 gfc_array_r4
* const restrict array
, GFC_REAL_4 value
,
332 GFC_LOGICAL_4
*, GFC_LOGICAL_4
);
333 export_proto(sfindloc0_r4
);
336 sfindloc0_r4 (gfc_array_index_type
* const restrict retarray
,
337 gfc_array_r4
* const restrict array
, GFC_REAL_4 value
,
338 GFC_LOGICAL_4
* mask
, GFC_LOGICAL_4 back
)
342 index_type
* restrict dest
;
345 if (mask
== NULL
|| *mask
)
347 findloc0_r4 (retarray
, array
, value
, back
);
351 rank
= GFC_DESCRIPTOR_RANK (array
);
354 internal_error (NULL
, "Rank of array needs to be > 0");
356 if (retarray
->base_addr
== NULL
)
358 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
359 retarray
->dtype
.rank
= 1;
360 retarray
->offset
= 0;
361 retarray
->base_addr
= xmallocarray (rank
, sizeof (index_type
));
363 else if (unlikely (compile_options
.bounds_check
))
365 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
369 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
370 dest
= retarray
->base_addr
;
371 for (n
= 0; n
<rank
; n
++)
372 dest
[n
* dstride
] = 0 ;