libgfortran/generated/maxval_r8.c

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