libgfortran/generated/minval_r16.c

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