1248484Sneel/* Implementation of the FINDLOC intrinsic 2248484Sneel Copyright (C) 2018-2020 Free Software Foundation, Inc. 3248484Sneel Contributed by Thomas K��nig <tk@tkoenig.net> 4248484Sneel 5248484SneelThis file is part of the GNU Fortran 95 runtime library (libgfortran). 6248484Sneel 7248484SneelLibgfortran is free software; you can redistribute it and/or 8248484Sneelmodify it under the terms of the GNU General Public 9248484SneelLicense as published by the Free Software Foundation; either 10248484Sneelversion 3 of the License, or (at your option) any later version. 11248484Sneel 12248484SneelLibgfortran is distributed in the hope that it will be useful, 13248484Sneelbut WITHOUT ANY WARRANTY; without even the implied warranty of 14248484SneelMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15248484SneelGNU General Public License for more details. 16248484Sneel 17248484SneelUnder Section 7 of GPL version 3, you are granted additional 18248484Sneelpermissions described in the GCC Runtime Library Exception, version 19248484Sneel3.1, as published by the Free Software Foundation. 20248484Sneel 21248484SneelYou should have received a copy of the GNU General Public License and 22248484Sneela copy of the GCC Runtime Library Exception along with this program; 23248484Sneelsee the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24248484Sneel<http://www.gnu.org/licenses/>. */ 25248484Sneel 26248484Sneel#include "libgfortran.h" 27248484Sneel#include <assert.h> 28248484Sneel 29248484Sneel#if defined (HAVE_GFC_REAL_8) 30248484Sneelextern void findloc1_r8 (gfc_array_index_type * const restrict retarray, 31248484Sneel gfc_array_r8 * const restrict array, GFC_REAL_8 value, 32248484Sneel const index_type * restrict pdim, GFC_LOGICAL_4 back); 33248484Sneelexport_proto(findloc1_r8); 34256176Sneel 35248484Sneelextern void 36248484Sneelfindloc1_r8 (gfc_array_index_type * const restrict retarray, 37248484Sneel gfc_array_r8 * const restrict array, GFC_REAL_8 value, 38248484Sneel const index_type * restrict pdim, GFC_LOGICAL_4 back) 39248484Sneel{ 40248484Sneel index_type count[GFC_MAX_DIMENSIONS]; 41248484Sneel index_type extent[GFC_MAX_DIMENSIONS]; 42256657Sneel index_type sstride[GFC_MAX_DIMENSIONS]; 43248484Sneel index_type dstride[GFC_MAX_DIMENSIONS]; 44248484Sneel const GFC_REAL_8 * restrict base; 45248484Sneel index_type * restrict dest; 46248484Sneel index_type rank; 47256657Sneel index_type n; 48248840Sneel index_type len; 49248484Sneel index_type delta; 50248484Sneel index_type dim; 51256176Sneel int continue_loop; 52248484Sneel 53248484Sneel /* Make dim zero based to avoid confusion. */ 54248484Sneel rank = GFC_DESCRIPTOR_RANK (array) - 1; 55248484Sneel dim = (*pdim) - 1; 56248484Sneel 57248484Sneel if (unlikely (dim < 0 || dim > rank)) 58248484Sneel { 59248484Sneel runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " 60248484Sneel "is %ld, should be between 1 and %ld", 61248484Sneel (long int) dim + 1, (long int) rank + 1); 62248484Sneel } 63248484Sneel 64248484Sneel len = GFC_DESCRIPTOR_EXTENT(array,dim); 65248484Sneel if (len < 0) 66248484Sneel len = 0; 67248484Sneel delta = GFC_DESCRIPTOR_STRIDE(array,dim); 68248484Sneel 69248484Sneel for (n = 0; n < dim; n++) 70248484Sneel { 71248484Sneel sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 72248484Sneel extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 73248484Sneel 74248484Sneel if (extent[n] < 0) 75248484Sneel extent[n] = 0; 76248840Sneel } 77256657Sneel for (n = dim; n < rank; n++) 78248484Sneel { 79256657Sneel sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); 80248484Sneel extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 81248484Sneel 82248484Sneel if (extent[n] < 0) 83248484Sneel extent[n] = 0; 84248484Sneel } 85248484Sneel 86248484Sneel if (retarray->base_addr == NULL) 87248484Sneel { 88248484Sneel size_t alloc_size, str; 89248484Sneel 90256657Sneel for (n = 0; n < rank; n++) 91256657Sneel { 92256657Sneel if (n == 0) 93248840Sneel str = 1; 94248840Sneel else 95248484Sneel str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 96248484Sneel 97248484Sneel GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 98248484Sneel 99248484Sneel } 100248484Sneel 101248484Sneel retarray->offset = 0; 102248484Sneel retarray->dtype.rank = rank; 103248484Sneel 104248484Sneel alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 105248484Sneel 106248484Sneel retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); 107248484Sneel if (alloc_size == 0) 108248484Sneel { 109248484Sneel /* Make sure we have a zero-sized array. */ 110248484Sneel GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); 111248484Sneel return; 112248484Sneel } 113248484Sneel } 114248484Sneel else 115248484Sneel { 116248484Sneel if (rank != GFC_DESCRIPTOR_RANK (retarray)) 117248484Sneel runtime_error ("rank of return array incorrect in" 118248484Sneel " FINDLOC intrinsic: is %ld, should be %ld", 119248484Sneel (long int) (GFC_DESCRIPTOR_RANK (retarray)), 120248484Sneel (long int) rank); 121248484Sneel 122248484Sneel if (unlikely (compile_options.bounds_check)) 123248484Sneel bounds_ifunction_return ((array_t *) retarray, extent, 124248484Sneel "return value", "FINDLOC"); 125248484Sneel } 126248484Sneel 127248484Sneel for (n = 0; n < rank; n++) 128248484Sneel { 129248484Sneel count[n] = 0; 130248484Sneel dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); 131248484Sneel if (extent[n] <= 0) 132248484Sneel return; 133248484Sneel } 134248484Sneel 135248484Sneel dest = retarray->base_addr; 136248484Sneel continue_loop = 1; 137248484Sneel 138248484Sneel base = array->base_addr; 139248484Sneel while (continue_loop) 140248484Sneel { 141248484Sneel const GFC_REAL_8 * restrict src; 142248484Sneel index_type result; 143248484Sneel 144248484Sneel result = 0; 145248484Sneel if (back) 146248484Sneel { 147248484Sneel src = base + (len - 1) * delta * 1; 148248484Sneel for (n = len; n > 0; n--, src -= delta * 1) 149248484Sneel { 150248484Sneel if (*src == value) 151248484Sneel { 152248484Sneel result = n; 153248484Sneel break; 154248484Sneel } 155248484Sneel } 156248484Sneel } 157248484Sneel else 158248484Sneel { 159248484Sneel src = base; 160248484Sneel for (n = 1; n <= len; n++, src += delta * 1) 161248484Sneel { 162248484Sneel if (*src == value) 163248484Sneel { 164248484Sneel result = n; 165248484Sneel break; 166248484Sneel } 167248484Sneel } 168248484Sneel } 169248484Sneel *dest = result; 170248484Sneel 171256657Sneel count[0]++; 172248484Sneel base += sstride[0] * 1; 173248484Sneel dest += dstride[0]; 174248484Sneel n = 0; 175248484Sneel while (count[n] == extent[n]) 176248840Sneel { 177248840Sneel count[n] = 0; 178248484Sneel base -= sstride[n] * extent[n] * 1; 179248484Sneel dest -= dstride[n] * extent[n]; 180248484Sneel n++; 181248484Sneel if (n >= rank) 182248484Sneel { 183248484Sneel continue_loop = 0; 184248484Sneel break; 185248484Sneel } 186248484Sneel else 187248484Sneel { 188248484Sneel count[n]++; 189248484Sneel base += sstride[n] * 1; 190 dest += dstride[n]; 191 } 192 } 193 } 194} 195extern void mfindloc1_r8 (gfc_array_index_type * const restrict retarray, 196 gfc_array_r8 * const restrict array, GFC_REAL_8 value, 197 const index_type * restrict pdim, gfc_array_l1 *const restrict mask, 198 GFC_LOGICAL_4 back); 199export_proto(mfindloc1_r8); 200 201extern void 202mfindloc1_r8 (gfc_array_index_type * const restrict retarray, 203 gfc_array_r8 * const restrict array, GFC_REAL_8 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_8 * 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_8 * 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} 388extern void sfindloc1_r8 (gfc_array_index_type * const restrict retarray, 389 gfc_array_r8 * const restrict array, GFC_REAL_8 value, 390 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask, 391 GFC_LOGICAL_4 back); 392export_proto(sfindloc1_r8); 393 394extern void 395sfindloc1_r8 (gfc_array_index_type * const restrict retarray, 396 gfc_array_r8 * const restrict array, GFC_REAL_8 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_r8 (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