1 /* Implementation of the FINDLOC intrinsic 2 Copyright (C) 2018-2022 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_17) 30 extern void findloc1_r17 (gfc_array_index_type * const restrict retarray, 31 gfc_array_r17 * const restrict array, GFC_REAL_17 value, 32 const index_type * restrict pdim, GFC_LOGICAL_4 back); 33 export_proto(findloc1_r17); 34 35 extern void 36 findloc1_r17 (gfc_array_index_type * const restrict retarray, 37 gfc_array_r17 * const restrict array, GFC_REAL_17 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_17 * 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 { 109 /* Make sure we have a zero-sized array. */ 110 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 111 return; 112 } 113 } 114 else 115 { 116 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 117 runtime_error ("rank of return array incorrect in" 118 " FINDLOC intrinsic: is %ld, should be %ld", 119 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 120 (long int) rank); 121 122 if (unlikely (compile_options.bounds_check)) 123 bounds_ifunction_return ((array_t *) retarray, extent, 124 "return value", "FINDLOC"); 125 } 126 127 for (n = 0; n < rank; n++) 128 { 129 count[n] = 0; 130 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 131 if (extent[n] <= 0) 132 return; 133 } 134 135 dest = retarray->base_addr; 136 continue_loop = 1; 137 138 base = array->base_addr; 139 while (continue_loop) 140 { 141 const GFC_REAL_17 * restrict src; 142 index_type result; 143 144 result = 0; 145 if (back) 146 { 147 src = base + (len - 1) * delta * 1; 148 for (n = len; n > 0; n--, src -= delta * 1) 149 { 150 if (*src == value) 151 { 152 result = n; 153 break; 154 } 155 } 156 } 157 else 158 { 159 src = base; 160 for (n = 1; n <= len; n++, src += delta * 1) 161 { 162 if (*src == value) 163 { 164 result = n; 165 break; 166 } 167 } 168 } 169 *dest = result; 170 171 count[0]++; 172 base += sstride[0] * 1; 173 dest += dstride[0]; 174 n = 0; 175 while (count[n] == extent[n]) 176 { 177 count[n] = 0; 178 base -= sstride[n] * extent[n] * 1; 179 dest -= dstride[n] * extent[n]; 180 n++; 181 if (n >= rank) 182 { 183 continue_loop = 0; 184 break; 185 } 186 else 187 { 188 count[n]++; 189 base += sstride[n] * 1; 190 dest += dstride[n]; 191 } 192 } 193 } 194 } 195 extern void mfindloc1_r17 (gfc_array_index_type * const restrict retarray, 196 gfc_array_r17 * const restrict array, GFC_REAL_17 value, 197 const index_type * restrict pdim, gfc_array_l1 *const restrict mask, 198 GFC_LOGICAL_4 back); 199 export_proto(mfindloc1_r17); 200 201 extern void 202 mfindloc1_r17 (gfc_array_index_type * const restrict retarray, 203 gfc_array_r17 * const restrict array, GFC_REAL_17 value, 204 const index_type * restrict pdim, gfc_array_l1 *const restrict mask, 205 GFC_LOGICAL_4 back) 206 { 207 index_type count[GFC_MAX_DIMENSIONS]; 208 index_type extent[GFC_MAX_DIMENSIONS]; 209 index_type sstride[GFC_MAX_DIMENSIONS]; 210 index_type mstride[GFC_MAX_DIMENSIONS]; 211 index_type dstride[GFC_MAX_DIMENSIONS]; 212 const GFC_REAL_17 * restrict base; 213 const GFC_LOGICAL_1 * restrict mbase; 214 index_type * restrict dest; 215 index_type rank; 216 index_type n; 217 index_type len; 218 index_type delta; 219 index_type mdelta; 220 index_type dim; 221 int mask_kind; 222 int continue_loop; 223 224 /* Make dim zero based to avoid confusion. */ 225 rank = GFC_DESCRIPTOR_RANK (array) - 1; 226 dim = (*pdim) - 1; 227 228 if (unlikely (dim < 0 || dim > rank)) 229 { 230 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " 231 "is %ld, should be between 1 and %ld", 232 (long int) dim + 1, (long int) rank + 1); 233 } 234 235 len = GFC_DESCRIPTOR_EXTENT(array,dim); 236 if (len < 0) 237 len = 0; 238 239 delta = GFC_DESCRIPTOR_STRIDE(array,dim); 240 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); 241 242 mbase = mask->base_addr; 243 244 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 245 246 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 247 #ifdef HAVE_GFC_LOGICAL_16 248 || mask_kind == 16 249 #endif 250 ) 251 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 252 else 253 internal_error (NULL, "Funny sized logical array"); 254 255 for (n = 0; n < dim; n++) 256 { 257 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 258 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); 259 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 260 261 if (extent[n] < 0) 262 extent[n] = 0; 263 } 264 for (n = dim; n < rank; n++) 265 { 266 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); 267 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); 268 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 269 270 if (extent[n] < 0) 271 extent[n] = 0; 272 } 273 274 if (retarray->base_addr == NULL) 275 { 276 size_t alloc_size, str; 277 278 for (n = 0; n < rank; n++) 279 { 280 if (n == 0) 281 str = 1; 282 else 283 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 284 285 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 286 287 } 288 289 retarray->offset = 0; 290 retarray->dtype.rank = rank; 291 292 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 293 294 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); 295 if (alloc_size == 0) 296 { 297 /* Make sure we have a zero-sized array. */ 298 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 299 return; 300 } 301 } 302 else 303 { 304 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 305 runtime_error ("rank of return array incorrect in" 306 " FINDLOC intrinsic: is %ld, should be %ld", 307 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 308 (long int) rank); 309 310 if (unlikely (compile_options.bounds_check)) 311 bounds_ifunction_return ((array_t *) retarray, extent, 312 "return value", "FINDLOC"); 313 } 314 315 for (n = 0; n < rank; n++) 316 { 317 count[n] = 0; 318 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 319 if (extent[n] <= 0) 320 return; 321 } 322 323 dest = retarray->base_addr; 324 continue_loop = 1; 325 326 base = array->base_addr; 327 while (continue_loop) 328 { 329 const GFC_REAL_17 * restrict src; 330 const GFC_LOGICAL_1 * restrict msrc; 331 index_type result; 332 333 result = 0; 334 if (back) 335 { 336 src = base + (len - 1) * delta * 1; 337 msrc = mbase + (len - 1) * mdelta; 338 for (n = len; n > 0; n--, src -= delta * 1, msrc -= mdelta) 339 { 340 if (*msrc && *src == value) 341 { 342 result = n; 343 break; 344 } 345 } 346 } 347 else 348 { 349 src = base; 350 msrc = mbase; 351 for (n = 1; n <= len; n++, src += delta * 1, msrc += mdelta) 352 { 353 if (*msrc && *src == value) 354 { 355 result = n; 356 break; 357 } 358 } 359 } 360 *dest = result; 361 362 count[0]++; 363 base += sstride[0] * 1; 364 mbase += mstride[0]; 365 dest += dstride[0]; 366 n = 0; 367 while (count[n] == extent[n]) 368 { 369 count[n] = 0; 370 base -= sstride[n] * extent[n] * 1; 371 mbase -= mstride[n] * extent[n]; 372 dest -= dstride[n] * extent[n]; 373 n++; 374 if (n >= rank) 375 { 376 continue_loop = 0; 377 break; 378 } 379 else 380 { 381 count[n]++; 382 base += sstride[n] * 1; 383 dest += dstride[n]; 384 } 385 } 386 } 387 } 388 extern void sfindloc1_r17 (gfc_array_index_type * const restrict retarray, 389 gfc_array_r17 * const restrict array, GFC_REAL_17 value, 390 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask, 391 GFC_LOGICAL_4 back); 392 export_proto(sfindloc1_r17); 393 394 extern void 395 sfindloc1_r17 (gfc_array_index_type * const restrict retarray, 396 gfc_array_r17 * const restrict array, GFC_REAL_17 value, 397 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask, 398 GFC_LOGICAL_4 back) 399 { 400 index_type count[GFC_MAX_DIMENSIONS]; 401 index_type extent[GFC_MAX_DIMENSIONS]; 402 index_type dstride[GFC_MAX_DIMENSIONS]; 403 index_type * restrict dest; 404 index_type rank; 405 index_type n; 406 index_type len; 407 index_type dim; 408 bool continue_loop; 409 410 if (mask == NULL || *mask) 411 { 412 findloc1_r17 (retarray, array, value, pdim, back); 413 return; 414 } 415 /* Make dim zero based to avoid confusion. */ 416 rank = GFC_DESCRIPTOR_RANK (array) - 1; 417 dim = (*pdim) - 1; 418 419 if (unlikely (dim < 0 || dim > rank)) 420 { 421 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " 422 "is %ld, should be between 1 and %ld", 423 (long int) dim + 1, (long int) rank + 1); 424 } 425 426 len = GFC_DESCRIPTOR_EXTENT(array,dim); 427 if (len < 0) 428 len = 0; 429 430 for (n = 0; n < dim; n++) 431 { 432 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 433 434 if (extent[n] <= 0) 435 extent[n] = 0; 436 } 437 438 for (n = dim; n < rank; n++) 439 { 440 extent[n] = 441 GFC_DESCRIPTOR_EXTENT(array,n + 1); 442 443 if (extent[n] <= 0) 444 extent[n] = 0; 445 } 446 447 448 if (retarray->base_addr == NULL) 449 { 450 size_t alloc_size, str; 451 452 for (n = 0; n < rank; n++) 453 { 454 if (n == 0) 455 str = 1; 456 else 457 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 458 459 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 460 } 461 462 retarray->offset = 0; 463 retarray->dtype.rank = rank; 464 465 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 466 467 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); 468 if (alloc_size == 0) 469 { 470 /* Make sure we have a zero-sized array. */ 471 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 472 return; 473 } 474 } 475 else 476 { 477 if (rank != GFC_DESCRIPTOR_RANK (retarray)) 478 runtime_error ("rank of return array incorrect in" 479 " FINDLOC intrinsic: is %ld, should be %ld", 480 (long int) (GFC_DESCRIPTOR_RANK (retarray)), 481 (long int) rank); 482 483 if (unlikely (compile_options.bounds_check)) 484 bounds_ifunction_return ((array_t *) retarray, extent, 485 "return value", "FINDLOC"); 486 } 487 488 for (n = 0; n < rank; n++) 489 { 490 count[n] = 0; 491 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 492 if (extent[n] <= 0) 493 return; 494 } 495 dest = retarray->base_addr; 496 continue_loop = 1; 497 498 while (continue_loop) 499 { 500 *dest = 0; 501 502 count[0]++; 503 dest += dstride[0]; 504 n = 0; 505 while (count[n] == extent[n]) 506 { 507 count[n] = 0; 508 dest -= dstride[n] * extent[n]; 509 n++; 510 if (n >= rank) 511 { 512 continue_loop = 0; 513 break; 514 } 515 else 516 { 517 count[n]++; 518 dest += dstride[n]; 519 } 520 } 521 } 522 } 523 #endif 524
Indexes created Wed Mar 25 00:23:37 UTC 2026