libgfortran/generated/findloc1_r17.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_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         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_17 * 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_r17 (gfc_array_index_type * const restrict retarray,
 192                          gfc_array_r17 * const restrict array, GFC_REAL_17 value,
 193                          const index_type * restrict pdim, gfc_array_l1 *const restrict mask,
 194                          GFC_LOGICAL_4 back);
 195 export_proto(mfindloc1_r17);
 196
 197 extern void
 198 mfindloc1_r17 (gfc_array_index_type * const restrict retarray,
 199             gfc_array_r17 * const restrict array, GFC_REAL_17 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_17 * 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_17 * 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_r17 (gfc_array_index_type * const restrict retarray,
 381                          gfc_array_r17 * const restrict array, GFC_REAL_17 value,
 382                          const index_type * restrict pdim, GFC_LOGICAL_4 *const restrict mask,
 383                          GFC_LOGICAL_4 back);
 384 export_proto(sfindloc1_r17);
 385
 386 extern void
 387 sfindloc1_r17 (gfc_array_index_type * const restrict retarray,
 388             gfc_array_r17 * const restrict array, GFC_REAL_17 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_r17 (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