1240116Smarcel/* Implementation of the FINDLOC intrinsic 2240116Smarcel Copyright (C) 2018-2022 Free Software Foundation, Inc. 3240116Smarcel Contributed by Thomas K��nig <tk@tkoenig.net> 4240116Smarcel 5240116SmarcelThis file is part of the GNU Fortran 95 runtime library (libgfortran). 6240116Smarcel 7240116SmarcelLibgfortran is free software; you can redistribute it and/or 8240116Smarcelmodify it under the terms of the GNU General Public 9240116SmarcelLicense as published by the Free Software Foundation; either 10240116Smarcelversion 3 of the License, or (at your option) any later version. 11240116Smarcel 12240116SmarcelLibgfortran is distributed in the hope that it will be useful, 13240116Smarcelbut WITHOUT ANY WARRANTY; without even the implied warranty of 14240116SmarcelMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15240116SmarcelGNU General Public License for more details. 16240116Smarcel 17240116SmarcelUnder Section 7 of GPL version 3, you are granted additional 18240116Smarcelpermissions described in the GCC Runtime Library Exception, version 19240116Smarcel3.1, as published by the Free Software Foundation. 20240116Smarcel 21240116SmarcelYou should have received a copy of the GNU General Public License and 22240116Smarcela copy of the GCC Runtime Library Exception along with this program; 23240116Smarcelsee the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24240116Smarcel<http://www.gnu.org/licenses/>. */ 25275988Sngie 26240116Smarcel#include "libgfortran.h" 27240116Smarcel#include <assert.h> 28240116Smarcel 29240116Smarcel#if defined (HAVE_GFC_COMPLEX_4) 30275988Sngieextern void findloc1_c4 (gfc_array_index_type * const restrict retarray, 31240116Smarcel gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value, 32240116Smarcel const index_type * restrict pdim, GFC_LOGICAL_4 back); 33240116Smarcelexport_proto(findloc1_c4); 34240116Smarcel 35240116Smarcelextern void 36240116Smarcelfindloc1_c4 (gfc_array_index_type * const restrict retarray, 37240116Smarcel gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value, 38240116Smarcel const index_type * restrict pdim, GFC_LOGICAL_4 back) 39240116Smarcel{ 40275988Sngie index_type count[GFC_MAX_DIMENSIONS]; 41240116Smarcel index_type extent[GFC_MAX_DIMENSIONS]; 42240116Smarcel index_type sstride[GFC_MAX_DIMENSIONS]; 43240116Smarcel index_type dstride[GFC_MAX_DIMENSIONS]; 44240116Smarcel const GFC_COMPLEX_4 * restrict base; 45272307Srodrigc index_type * restrict dest; 46272307Srodrigc index_type rank; 47240116Smarcel index_type n; 48240116Smarcel index_type len; 49275988Sngie index_type delta; 50240116Smarcel index_type dim; 51275988Sngie int continue_loop; 52275988Sngie 53275988Sngie /* Make dim zero based to avoid confusion. */ 54275988Sngie rank = GFC_DESCRIPTOR_RANK (array) - 1; 55240116Smarcel dim = (*pdim) - 1; 56275988Sngie 57275988Sngie if (unlikely (dim < 0 || dim > rank)) 58275988Sngie { 59275988Sngie runtime_error ("Dim argument incorrect in FINDLOC intrinsic: " 60275988Sngie "is %ld, should be between 1 and %ld", 61275988Sngie (long int) dim + 1, (long int) rank + 1); 62275988Sngie } 63275988Sngie 64275988Sngie len = GFC_DESCRIPTOR_EXTENT(array,dim); 65275988Sngie if (len < 0) 66275988Sngie len = 0; 67275988Sngie delta = GFC_DESCRIPTOR_STRIDE(array,dim); 68275988Sngie 69275988Sngie for (n = 0; n < dim; n++) 70275988Sngie { 71275988Sngie sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); 72275988Sngie extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); 73275988Sngie 74275988Sngie if (extent[n] < 0) 75275988Sngie extent[n] = 0; 76275988Sngie } 77275988Sngie for (n = dim; n < rank; n++) 78275988Sngie { 79275988Sngie sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); 80240116Smarcel extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); 81275988Sngie 82240116Smarcel if (extent[n] < 0) 83240116Smarcel extent[n] = 0; 84240116Smarcel } 85240116Smarcel 86240116Smarcel if (retarray->base_addr == NULL) 87275988Sngie { 88275988Sngie size_t alloc_size, str; 89275988Sngie 90275988Sngie for (n = 0; n < rank; n++) 91275988Sngie { 92275988Sngie if (n == 0) 93275988Sngie str = 1; 94275988Sngie else 95275988Sngie str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; 96275988Sngie 97275988Sngie GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); 98275988Sngie 99275988Sngie } 100275988Sngie 101272307Srodrigc retarray->offset = 0; 102272307Srodrigc retarray->dtype.rank = rank; 103272307Srodrigc 104272307Srodrigc alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; 105272307Srodrigc 106240116Smarcel retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type)); 107275988Sngie 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_COMPLEX_4 * 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} 195extern void mfindloc1_c4 (gfc_array_index_type * const restrict retarray, 196 gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value, 197 const index_type * restrict pdim, gfc_array_l1 *const restrict mask, 198 GFC_LOGICAL_4 back); 199export_proto(mfindloc1_c4); 200 201extern void 202mfindloc1_c4 (gfc_array_index_type * const restrict retarray, 203 gfc_array_c4 * const restrict array, GFC_COMPLEX_4 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_COMPLEX_4 * 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_COMPLEX_4 * 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_c4 (gfc_array_index_type * const restrict retarray, 389 gfc_array_c4 * const restrict array, GFC_COMPLEX_4 value, 390 const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask, 391 GFC_LOGICAL_4 back); 392export_proto(sfindloc1_c4); 393 394extern void 395sfindloc1_c4 (gfc_array_index_type * const restrict retarray, 396 gfc_array_c4 * const restrict array, GFC_COMPLEX_4 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_c4 (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