libgfortran/generated/findloc1_r8.c

   1 /* Implementation of the FINDLOC intrinsic
   2    Copyright (C) 2018-2023 Free Software Foundation, Inc.
   3    Contributed by Thomas König <tk@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_8)
  30 extern void findloc1_r8 (gfc_array_index_type * const restrict retarray,
  31                          gfc_array_r8 * const restrict array, GFC_REAL_8 value,
  32                          const index_type * restrict pdim, GFC_LOGICAL_4 back);
  33 export_proto(findloc1_r8);
  34
  35 extern void
  36 findloc1_r8 (gfc_array_index_type * const restrict retarray,
  37             gfc_array_r8 * const restrict array, GFC_REAL_8 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_8 * 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_8 * 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_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);
 199 export_proto(mfindloc1_r8);
 200
 201 extern void
 202 mfindloc1_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 }
 388 extern 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);
 392 export_proto(sfindloc1_r8);
 393
 394 extern void
 395 sfindloc1_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