libgfortran/generated/maxloc1_4_r17.c

   1 /* Implementation of the MAXLOC intrinsic
   2    Copyright (C) 2002-2023 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 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
  30 #if defined (HAVE_GFC_REAL_17) && defined (HAVE_GFC_INTEGER_4)
  31
  32 #define HAVE_BACK_ARG 1
  33
  34
  35 extern void maxloc1_4_r17 (gfc_array_i4 * const restrict,
  36         gfc_array_r17 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
  37 export_proto(maxloc1_4_r17);
  38
  39 void
  40 maxloc1_4_r17 (gfc_array_i4 * const restrict retarray,
  41         gfc_array_r17 * const restrict array,
  42         const index_type * const restrict pdim, GFC_LOGICAL_4 back)
  43 {
  44   index_type count[GFC_MAX_DIMENSIONS];
  45   index_type extent[GFC_MAX_DIMENSIONS];
  46   index_type sstride[GFC_MAX_DIMENSIONS];
  47   index_type dstride[GFC_MAX_DIMENSIONS];
  48   const GFC_REAL_17 * restrict base;
  49   GFC_INTEGER_4 * restrict dest;
  50   index_type rank;
  51   index_type n;
  52   index_type len;
  53   index_type delta;
  54   index_type dim;
  55   int continue_loop;
  56
  57   /* Make dim zero based to avoid confusion.  */
  58   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  59   dim = (*pdim) - 1;
  60
  61   if (unlikely (dim < 0 || dim > rank))
  62     {
  63       runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
  64                      "is %ld, should be between 1 and %ld",
  65                      (long int) dim + 1, (long int) rank + 1);
  66     }
  67
  68   len = GFC_DESCRIPTOR_EXTENT(array,dim);
  69   if (len < 0)
  70     len = 0;
  71   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  72
  73   for (n = 0; n < dim; n++)
  74     {
  75       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  76       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  77
  78       if (extent[n] < 0)
  79         extent[n] = 0;
  80     }
  81   for (n = dim; n < rank; n++)
  82     {
  83       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
  84       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
  85
  86       if (extent[n] < 0)
  87         extent[n] = 0;
  88     }
  89
  90   if (retarray->base_addr == NULL)
  91     {
  92       size_t alloc_size, str;
  93
  94       for (n = 0; n < rank; n++)
  95         {
  96           if (n == 0)
  97             str = 1;
  98           else
  99             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 100
 101           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 102
 103         }
 104
 105       retarray->offset = 0;
 106       retarray->dtype.rank = rank;
 107
 108       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 109
 110       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 111       if (alloc_size == 0)
 112         return;
 113     }
 114   else
 115     {
 116       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 117         runtime_error ("rank of return array incorrect in"
 118                        " MAXLOC 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", "MAXLOC");
 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   base = array->base_addr;
 136   dest = retarray->base_addr;
 137
 138   continue_loop = 1;
 139   while (continue_loop)
 140     {
 141       const GFC_REAL_17 * restrict src;
 142       GFC_INTEGER_4 result;
 143       src = base;
 144       {
 145
 146         GFC_REAL_17 maxval;
 147 #if defined (GFC_REAL_17_INFINITY)
 148         maxval = -GFC_REAL_17_INFINITY;
 149 #else
 150         maxval = -GFC_REAL_17_HUGE;
 151 #endif
 152         result = 1;
 153         if (len <= 0)
 154           *dest = 0;
 155         else
 156           {
 157 #if ! defined HAVE_BACK_ARG
 158             for (n = 0; n < len; n++, src += delta)
 159               {
 160 #endif
 161
 162 #if defined (GFC_REAL_17_QUIET_NAN)
 163              for (n = 0; n < len; n++, src += delta)
 164                {
 165                 if (*src >= maxval)
 166                   {
 167                     maxval = *src;
 168                     result = (GFC_INTEGER_4)n + 1;
 169                     break;
 170                   }
 171               }
 172 #else
 173             n = 0;
 174 #endif
 175             for (; n < len; n++, src += delta)
 176               {
 177                 if (back ? *src >= maxval : *src > maxval)
 178                   {
 179                     maxval = *src;
 180                     result = (GFC_INTEGER_4)n + 1;
 181                   }
 182               }
 183
 184             *dest = result;
 185           }
 186       }
 187       /* Advance to the next element.  */
 188       count[0]++;
 189       base += sstride[0];
 190       dest += dstride[0];
 191       n = 0;
 192       while (count[n] == extent[n])
 193         {
 194           /* When we get to the end of a dimension, reset it and increment
 195              the next dimension.  */
 196           count[n] = 0;
 197           /* We could precalculate these products, but this is a less
 198              frequently used path so probably not worth it.  */
 199           base -= sstride[n] * extent[n];
 200           dest -= dstride[n] * extent[n];
 201           n++;
 202           if (n >= rank)
 203             {
 204               /* Break out of the loop.  */
 205               continue_loop = 0;
 206               break;
 207             }
 208           else
 209             {
 210               count[n]++;
 211               base += sstride[n];
 212               dest += dstride[n];
 213             }
 214         }
 215     }
 216 }
 217
 218
 219 extern void mmaxloc1_4_r17 (gfc_array_i4 * const restrict,
 220         gfc_array_r17 * const restrict, const index_type * const restrict,
 221         gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
 222 export_proto(mmaxloc1_4_r17);
 223
 224 void
 225 mmaxloc1_4_r17 (gfc_array_i4 * const restrict retarray,
 226         gfc_array_r17 * const restrict array,
 227         const index_type * const restrict pdim,
 228         gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
 229 {
 230   index_type count[GFC_MAX_DIMENSIONS];
 231   index_type extent[GFC_MAX_DIMENSIONS];
 232   index_type sstride[GFC_MAX_DIMENSIONS];
 233   index_type dstride[GFC_MAX_DIMENSIONS];
 234   index_type mstride[GFC_MAX_DIMENSIONS];
 235   GFC_INTEGER_4 * restrict dest;
 236   const GFC_REAL_17 * restrict base;
 237   const GFC_LOGICAL_1 * restrict mbase;
 238   index_type rank;
 239   index_type dim;
 240   index_type n;
 241   index_type len;
 242   index_type delta;
 243   index_type mdelta;
 244   int mask_kind;
 245
 246   if (mask == NULL)
 247     {
 248 #ifdef HAVE_BACK_ARG
 249       maxloc1_4_r17 (retarray, array, pdim, back);
 250 #else
 251       maxloc1_4_r17 (retarray, array, pdim);
 252 #endif
 253       return;
 254     }
 255
 256   dim = (*pdim) - 1;
 257   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 258
 259
 260   if (unlikely (dim < 0 || dim > rank))
 261     {
 262       runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
 263                      "is %ld, should be between 1 and %ld",
 264                      (long int) dim + 1, (long int) rank + 1);
 265     }
 266
 267   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 268   if (len < 0)
 269     len = 0;
 270
 271   mbase = mask->base_addr;
 272
 273   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 274
 275   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 276 #ifdef HAVE_GFC_LOGICAL_16
 277       || mask_kind == 16
 278 #endif
 279       )
 280     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 281   else
 282     runtime_error ("Funny sized logical array");
 283
 284   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 285   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 286
 287   for (n = 0; n < dim; n++)
 288     {
 289       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 290       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 291       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 292
 293       if (extent[n] < 0)
 294         extent[n] = 0;
 295
 296     }
 297   for (n = dim; n < rank; n++)
 298     {
 299       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 300       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 301       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 302
 303       if (extent[n] < 0)
 304         extent[n] = 0;
 305     }
 306
 307   if (retarray->base_addr == NULL)
 308     {
 309       size_t alloc_size, str;
 310
 311       for (n = 0; n < rank; n++)
 312         {
 313           if (n == 0)
 314             str = 1;
 315           else
 316             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 317
 318           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 319
 320         }
 321
 322       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 323
 324       retarray->offset = 0;
 325       retarray->dtype.rank = rank;
 326
 327       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 328       if (alloc_size == 0)
 329         return;
 330     }
 331   else
 332     {
 333       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 334         runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
 335
 336       if (unlikely (compile_options.bounds_check))
 337         {
 338           bounds_ifunction_return ((array_t *) retarray, extent,
 339                                    "return value", "MAXLOC");
 340           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 341                                 "MASK argument", "MAXLOC");
 342         }
 343     }
 344
 345   for (n = 0; n < rank; n++)
 346     {
 347       count[n] = 0;
 348       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 349       if (extent[n] <= 0)
 350         return;
 351     }
 352
 353   dest = retarray->base_addr;
 354   base = array->base_addr;
 355
 356   while (base)
 357     {
 358       const GFC_REAL_17 * restrict src;
 359       const GFC_LOGICAL_1 * restrict msrc;
 360       GFC_INTEGER_4 result;
 361       src = base;
 362       msrc = mbase;
 363       {
 364
 365         GFC_REAL_17 maxval;
 366 #if defined (GFC_REAL_17_INFINITY)
 367         maxval = -GFC_REAL_17_INFINITY;
 368 #else
 369         maxval = -GFC_REAL_17_HUGE;
 370 #endif
 371 #if defined (GFC_REAL_17_QUIET_NAN)
 372         GFC_INTEGER_4 result2 = 0;
 373 #endif
 374         result = 0;
 375         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 376           {
 377
 378                 if (*msrc)
 379                   {
 380 #if defined (GFC_REAL_17_QUIET_NAN)
 381                     if (!result2)
 382                       result2 = (GFC_INTEGER_4)n + 1;
 383                     if (*src >= maxval)
 384 #endif
 385                       {
 386                         maxval = *src;
 387                         result = (GFC_INTEGER_4)n + 1;
 388                         break;
 389                       }
 390                   }
 391               }
 392 #if defined (GFC_REAL_17_QUIET_NAN)
 393             if (unlikely (n >= len))
 394               result = result2;
 395             else
 396 #endif
 397             if (back)
 398               for (; n < len; n++, src += delta, msrc += mdelta)
 399                 {
 400                   if (*msrc && unlikely (*src >= maxval))
 401                     {
 402                       maxval = *src;
 403                       result = (GFC_INTEGER_4)n + 1;
 404                     }
 405                 }
 406             else
 407               for (; n < len; n++, src += delta, msrc += mdelta)
 408                 {
 409                   if (*msrc && unlikely (*src > maxval))
 410                     {
 411                       maxval = *src;
 412                       result = (GFC_INTEGER_4)n + 1;
 413                     }
 414           }
 415         *dest = result;
 416       }
 417       /* Advance to the next element.  */
 418       count[0]++;
 419       base += sstride[0];
 420       mbase += mstride[0];
 421       dest += dstride[0];
 422       n = 0;
 423       while (count[n] == extent[n])
 424         {
 425           /* When we get to the end of a dimension, reset it and increment
 426              the next dimension.  */
 427           count[n] = 0;
 428           /* We could precalculate these products, but this is a less
 429              frequently used path so probably not worth it.  */
 430           base -= sstride[n] * extent[n];
 431           mbase -= mstride[n] * extent[n];
 432           dest -= dstride[n] * extent[n];
 433           n++;
 434           if (n >= rank)
 435             {
 436               /* Break out of the loop.  */
 437               base = NULL;
 438               break;
 439             }
 440           else
 441             {
 442               count[n]++;
 443               base += sstride[n];
 444               mbase += mstride[n];
 445               dest += dstride[n];
 446             }
 447         }
 448     }
 449 }
 450
 451
 452 extern void smaxloc1_4_r17 (gfc_array_i4 * const restrict,
 453         gfc_array_r17 * const restrict, const index_type * const restrict,
 454         GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
 455 export_proto(smaxloc1_4_r17);
 456
 457 void
 458 smaxloc1_4_r17 (gfc_array_i4 * const restrict retarray,
 459         gfc_array_r17 * const restrict array,
 460         const index_type * const restrict pdim,
 461         GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
 462 {
 463   index_type count[GFC_MAX_DIMENSIONS];
 464   index_type extent[GFC_MAX_DIMENSIONS];
 465   index_type dstride[GFC_MAX_DIMENSIONS];
 466   GFC_INTEGER_4 * restrict dest;
 467   index_type rank;
 468   index_type n;
 469   index_type dim;
 470
 471
 472   if (mask == NULL || *mask)
 473     {
 474 #ifdef HAVE_BACK_ARG
 475       maxloc1_4_r17 (retarray, array, pdim, back);
 476 #else
 477       maxloc1_4_r17 (retarray, array, pdim);
 478 #endif
 479       return;
 480     }
 481   /* Make dim zero based to avoid confusion.  */
 482   dim = (*pdim) - 1;
 483   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 484
 485   if (unlikely (dim < 0 || dim > rank))
 486     {
 487       runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
 488                      "is %ld, should be between 1 and %ld",
 489                      (long int) dim + 1, (long int) rank + 1);
 490     }
 491
 492   for (n = 0; n < dim; n++)
 493     {
 494       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 495
 496       if (extent[n] <= 0)
 497         extent[n] = 0;
 498     }
 499
 500   for (n = dim; n < rank; n++)
 501     {
 502       extent[n] =
 503         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 504
 505       if (extent[n] <= 0)
 506         extent[n] = 0;
 507     }
 508
 509   if (retarray->base_addr == NULL)
 510     {
 511       size_t alloc_size, str;
 512
 513       for (n = 0; n < rank; n++)
 514         {
 515           if (n == 0)
 516             str = 1;
 517           else
 518             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 519
 520           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 521
 522         }
 523
 524       retarray->offset = 0;
 525       retarray->dtype.rank = rank;
 526
 527       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 528
 529       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 530       if (alloc_size == 0)
 531         return;
 532     }
 533   else
 534     {
 535       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 536         runtime_error ("rank of return array incorrect in"
 537                        " MAXLOC intrinsic: is %ld, should be %ld",
 538                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 539                        (long int) rank);
 540
 541       if (unlikely (compile_options.bounds_check))
 542         {
 543           for (n=0; n < rank; n++)
 544             {
 545               index_type ret_extent;
 546
 547               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 548               if (extent[n] != ret_extent)
 549                 runtime_error ("Incorrect extent in return value of"
 550                                " MAXLOC intrinsic in dimension %ld:"
 551                                " is %ld, should be %ld", (long int) n + 1,
 552                                (long int) ret_extent, (long int) extent[n]);
 553             }
 554         }
 555     }
 556
 557   for (n = 0; n < rank; n++)
 558     {
 559       count[n] = 0;
 560       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 561     }
 562
 563   dest = retarray->base_addr;
 564
 565   while(1)
 566     {
 567       *dest = 0;
 568       count[0]++;
 569       dest += dstride[0];
 570       n = 0;
 571       while (count[n] == extent[n])
 572         {
 573           /* When we get to the end of a dimension, reset it and increment
 574              the next dimension.  */
 575           count[n] = 0;
 576           /* We could precalculate these products, but this is a less
 577              frequently used path so probably not worth it.  */
 578           dest -= dstride[n] * extent[n];
 579           n++;
 580           if (n >= rank)
 581             return;
 582           else
 583             {
 584               count[n]++;
 585               dest += dstride[n];
 586             }
 587         }
 588     }
 589 }
 590
 591 #endif