1 /* Implementation of the FINDLOC intrinsic 2 Copyright (C) 2018-2024 Free Software Foundation, Inc. 3 Contributed by Thomas Knig <tk (at) tkoenig.net> 4 5 This file is part of the GNU Fortran 95 runtime library (libgfortran). 6 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. 11 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. 16 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. 20 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/>. */ 25 26 #include "libgfortran.h" 27 #include <assert.h> 28 29 #if defined (HAVE_GFC_REAL_4) 30 extern void findloc1_r4 (gfc_array_index_type * const restrict retarray, 31 gfc_array_r4 * const restrict array, GFC_REAL_4 value, 32 const index_type * restrict pdim, GFC_LOGICAL_4 back); 33 export_proto(findloc1_r4); 34 35 extern void 36 findloc1_r4 (gfc_array_index_type * const restrict retarray, 37 gfc_array_r4 * const restrict array, GFC_REAL_4 value, 38 const index_type * restrict pdim, GFC_LOGICAL_4 back) 39 { 40 index_type count[GFC_MAX_DIMENSIONS]; 41 index_type extent[GFC_MAX_DIMENSIONS]; 42 index_type sstride[GFC_MAX_DIMENSIONS]; 43 index_type dstride[GFC_MAX_DIMENSIONS]; 44 const GFC_REAL_4 * restrict base; 45 index_type * restrict dest; 46 index_type rank; 47 index_type n; 48 index_type len; 49 index_type delta; 50 index_type dim; 51 int continue_loop; 52 53 /* Make dim zero based to avoid confusion. */ 54 rank = GFC_DESCRIPTOR_RANK (array) - 1; 55 dim = (*pdim) - 1; 56 57 if (unlikely (dim < 0 || dim > rank)) 58 { 59 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " 60 "is %ld, should be between 1 and %ld", 61 (long int) dim + 1, (long int) rank + 1); 62 } 63 64 len = GFC_DESCRIPTOR_EXTENT(array,dim); 65 if (len < 0) 66 len = 0; 67 delta = GFC_DESCRIPTOR_STRIDE(array,dim); 68 69 for (n = 0; n < dim; n++) 70 { 71 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 72 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 73 74 if (extent[n] < 0) 75 extent[n] = 0; 76 } 77 for (n = dim; n < rank; n++) 78 { 79 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); 80 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 81 82 if (extent[n] < 0) 83 extent[n] = 0; 84 } 85 86 if (retarray->base_addr == NULL) 87 { 88 size_t alloc_size, str; 89 90 for (n = 0; n < rank; n++) 91 { 92 if (n == 0) 93 str = 1; 94 else 95 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 96 97 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 98 99 } 100 101 retarray->offset = 0; 102 retarray->dtype.rank = rank; 103 104 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 105 106 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); 107 if (alloc_size == 0) 108 return; 109 } 110 else 111 { 112 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 113 runtime_error ("rank of return array incorrect in" 114 " FINDLOC intrinsic: is %ld, should be %ld", 115 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 116 (long int) rank); 117 118 if (unlikely (compile_options.bounds_check)) 119 bounds_ifunction_return ((array_t *) retarray, extent, 120 "return value", "FINDLOC"); 121 } 122 123 for (n = 0; n < rank; n++) 124 { 125 count[n] = 0; 126 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 127 if (extent[n] <= 0) 128 return; 129 } 130 131 dest = retarray->base_addr; 132 continue_loop = 1; 133 134 base = array->base_addr; 135 while (continue_loop) 136 { 137 const GFC_REAL_4 * restrict src; 138 index_type result; 139 140 result = 0; 141 if (back) 142 { 143 src = base + (len - 1) * delta * 1; 144 for (n = len; n > 0; n--, src -= delta * 1) 145 { 146 if (*src == value) 147 { 148 result = n; 149 break; 150 } 151 } 152 } 153 else 154 { 155 src = base; 156 for (n = 1; n <= len; n++, src += delta * 1) 157 { 158 if (*src == value) 159 { 160 result = n; 161 break; 162 } 163 } 164 } 165 *dest = result; 166 167 count[0]++; 168 base += sstride[0] * 1; 169 dest += dstride[0]; 170 n = 0; 171 while (count[n] == extent[n]) 172 { 173 count[n] = 0; 174 base -= sstride[n] * extent[n] * 1; 175 dest -= dstride[n] * extent[n]; 176 n++; 177 if (n >= rank) 178 { 179 continue_loop = 0; 180 break; 181 } 182 else 183 { 184 count[n]++; 185 base += sstride[n] * 1; 186 dest += dstride[n]; 187 } 188 } 189 } 190 } 191 extern void mfindloc1_r4 (gfc_array_index_type * const restrict retarray, 192 gfc_array_r4 * const restrict array, GFC_REAL_4 value, 193 const index_type * restrict pdim, gfc_array_l1 *const restrict mask, 194 GFC_LOGICAL_4 back); 195 export_proto(mfindloc1_r4); 196 197 extern void 198 mfindloc1_r4 (gfc_array_index_type * const restrict retarray, 199 gfc_array_r4 * const restrict array, GFC_REAL_4 value, 200 const index_type * restrict pdim, gfc_array_l1 *const restrict mask, 201 GFC_LOGICAL_4 back) 202 { 203 index_type count[GFC_MAX_DIMENSIONS]; 204 index_type extent[GFC_MAX_DIMENSIONS]; 205 index_type sstride[GFC_MAX_DIMENSIONS]; 206 index_type mstride[GFC_MAX_DIMENSIONS]; 207 index_type dstride[GFC_MAX_DIMENSIONS]; 208 const GFC_REAL_4 * restrict base; 209 const GFC_LOGICAL_1 * restrict mbase; 210 index_type * restrict dest; 211 index_type rank; 212 index_type n; 213 index_type len; 214 index_type delta; 215 index_type mdelta; 216 index_type dim; 217 int mask_kind; 218 int continue_loop; 219 220 /* Make dim zero based to avoid confusion. */ 221 rank = GFC_DESCRIPTOR_RANK (array) - 1; 222 dim = (*pdim) - 1; 223 224 if (unlikely (dim < 0 || dim > rank)) 225 { 226 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " 227 "is %ld, should be between 1 and %ld", 228 (long int) dim + 1, (long int) rank + 1); 229 } 230 231 len = GFC_DESCRIPTOR_EXTENT(array,dim); 232 if (len < 0) 233 len = 0; 234 235 delta = GFC_DESCRIPTOR_STRIDE(array,dim); 236 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); 237 238 mbase = mask->base_addr; 239 240 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 241 242 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 243 #ifdef HAVE_GFC_LOGICAL_16 244 || mask_kind == 16 245 #endif 246 ) 247 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 248 else 249 internal_error (NULL, "Funny sized logical array"); 250 251 for (n = 0; n < dim; n++) 252 { 253 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 254 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 255 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 256 257 if (extent[n] < 0) 258 extent[n] = 0; 259 } 260 for (n = dim; n < rank; n++) 261 { 262 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); 263 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); 264 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 265 266 if (extent[n] < 0) 267 extent[n] = 0; 268 } 269 270 if (retarray->base_addr == NULL) 271 { 272 size_t alloc_size, str; 273 274 for (n = 0; n < rank; n++) 275 { 276 if (n == 0) 277 str = 1; 278 else 279 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 280 281 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 282 283 } 284 285 retarray->offset = 0; 286 retarray->dtype.rank = rank; 287 288 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 289 290 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); 291 if (alloc_size == 0) 292 return; 293 } 294 else 295 { 296 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 297 runtime_error ("rank of return array incorrect in" 298 " FINDLOC intrinsic: is %ld, should be %ld", 299 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 300 (long int) rank); 301 302 if (unlikely (compile_options.bounds_check)) 303 bounds_ifunction_return ((array_t *) retarray, extent, 304 "return value", "FINDLOC"); 305 } 306 307 for (n = 0; n < rank; n++) 308 { 309 count[n] = 0; 310 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 311 if (extent[n] <= 0) 312 return; 313 } 314 315 dest = retarray->base_addr; 316 continue_loop = 1; 317 318 base = array->base_addr; 319 while (continue_loop) 320 { 321 const GFC_REAL_4 * restrict src; 322 const GFC_LOGICAL_1 * restrict msrc; 323 index_type result; 324 325 result = 0; 326 if (back) 327 { 328 src = base + (len - 1) * delta * 1; 329 msrc = mbase + (len - 1) * mdelta; 330 for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta) 331 { 332 if (*msrc && *src == value) 333 { 334 result = n; 335 break; 336 } 337 } 338 } 339 else 340 { 341 src = base; 342 msrc = mbase; 343 for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta) 344 { 345 if (*msrc && *src == value) 346 { 347 result = n; 348 break; 349 } 350 } 351 } 352 *dest = result; 353 354 count[0]++; 355 base += sstride[0] * 1; 356 mbase += mstride[0]; 357 dest += dstride[0]; 358 n = 0; 359 while (count[n] == extent[n]) 360 { 361 count[n] = 0; 362 base -= sstride[n] * extent[n] * 1; 363 mbase -= mstride[n] * extent[n]; 364 dest -= dstride[n] * extent[n]; 365 n++; 366 if (n >= rank) 367 { 368 continue_loop = 0; 369 break; 370 } 371 else 372 { 373 count[n]++; 374 base += sstride[n] * 1; 375 dest += dstride[n]; 376 } 377 } 378 } 379 } 380 extern void sfindloc1_r4 (gfc_array_index_type * const restrict retarray, 381 gfc_array_r4 * const restrict array, GFC_REAL_4 value, 382 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask, 383 GFC_LOGICAL_4 back); 384 export_proto(sfindloc1_r4); 385 386 extern void 387 sfindloc1_r4 (gfc_array_index_type * const restrict retarray, 388 gfc_array_r4 * const restrict array, GFC_REAL_4 value, 389 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask, 390 GFC_LOGICAL_4 back) 391 { 392 index_type count[GFC_MAX_DIMENSIONS]; 393 index_type extent[GFC_MAX_DIMENSIONS]; 394 index_type dstride[GFC_MAX_DIMENSIONS]; 395 index_type * restrict dest; 396 index_type rank; 397 index_type n; 398 index_type len; 399 index_type dim; 400 bool continue_loop; 401 402 if (mask == NULL || *mask) 403 { 404 findloc1_r4 (retarray, array, value, pdim, back); 405 return; 406 } 407 /* Make dim zero based to avoid confusion. */ 408 rank = GFC_DESCRIPTOR_RANK (array) - 1; 409 dim = (*pdim) - 1; 410 411 if (unlikely (dim < 0 || dim > rank)) 412 { 413 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " 414 "is %ld, should be between 1 and %ld", 415 (long int) dim + 1, (long int) rank + 1); 416 } 417 418 len = GFC_DESCRIPTOR_EXTENT(array,dim); 419 if (len < 0) 420 len = 0; 421 422 for (n = 0; n < dim; n++) 423 { 424 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 425 426 if (extent[n] <= 0) 427 extent[n] = 0; 428 } 429 430 for (n = dim; n < rank; n++) 431 { 432 extent[n] = 433 GFC_DESCRIPTOR_EXTENT(array,n + 1); 434 435 if (extent[n] <= 0) 436 extent[n] = 0; 437 } 438 439 440 if (retarray->base_addr == NULL) 441 { 442 size_t alloc_size, str; 443 444 for (n = 0; n < rank; n++) 445 { 446 if (n == 0) 447 str = 1; 448 else 449 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 450 451 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 452 } 453 454 retarray->offset = 0; 455 retarray->dtype.rank = rank; 456 457 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 458 459 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); 460 if (alloc_size == 0) 461 return; 462 } 463 else 464 { 465 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 466 runtime_error ("rank of return array incorrect in" 467 " FINDLOC intrinsic: is %ld, should be %ld", 468 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 469 (long int) rank); 470 471 if (unlikely (compile_options.bounds_check)) 472 bounds_ifunction_return ((array_t *) retarray, extent, 473 "return value", "FINDLOC"); 474 } 475 476 for (n = 0; n < rank; n++) 477 { 478 count[n] = 0; 479 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 480 if (extent[n] <= 0) 481 return; 482 } 483 dest = retarray->base_addr; 484 continue_loop = 1; 485 486 while (continue_loop) 487 { 488 *dest = 0; 489 490 count[0]++; 491 dest += dstride[0]; 492 n = 0; 493 while (count[n] == extent[n]) 494 { 495 count[n] = 0; 496 dest -= dstride[n] * extent[n]; 497 n++; 498 if (n >= rank) 499 { 500 continue_loop = 0; 501 break; 502 } 503 else 504 { 505 count[n]++; 506 dest += dstride[n]; 507 } 508 } 509 } 510 } 511 #endif 512
Indexes created Sun Mar 01 05:31:48 UTC 2026