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