libgfortran/generated/minval_r10.c

   1 /* Implementation of the MINVAL 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_10) && defined (HAVE_GFC_REAL_10)
  30
  31
  32 extern void minval_r10 (gfc_array_r10 * const restrict,
  33         gfc_array_r10 * const restrict, const index_type * const restrict);
  34 export_proto(minval_r10);
  35
  36 void
  37 minval_r10 (gfc_array_r10 * const restrict retarray,
  38         gfc_array_r10 * 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_10 * restrict base;
  46   GFC_REAL_10 * 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_10));
 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                        " MINVAL 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", "MINVAL");
 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_10 * restrict src;
 144       GFC_REAL_10 result;
 145       src = base;
 146       {
 147
 148 #if defined (GFC_REAL_10_INFINITY)
 149         result = GFC_REAL_10_INFINITY;
 150 #else
 151         result = GFC_REAL_10_HUGE;
 152 #endif
 153         if (len <= 0)
 154           *dest = GFC_REAL_10_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_10_QUIET_NAN)
 163                 if (*src <= result)
 164                   break;
 165               }
 166             if (unlikely (n >= len))
 167               result = GFC_REAL_10_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 mminval_r10 (gfc_array_r10 * const restrict,
 211         gfc_array_r10 * const restrict, const index_type * const restrict,
 212         gfc_array_l1 * const restrict);
 213 export_proto(mminval_r10);
 214
 215 void
 216 mminval_r10 (gfc_array_r10 * const restrict retarray,
 217         gfc_array_r10 * 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_10 * restrict dest;
 227   const GFC_REAL_10 * 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       minval_r10 (retarray, array, pdim, back);
 241 #else
 242       minval_r10 (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 MINVAL 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     len = 0;
 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       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
 319       if (alloc_size == 0)
 320         {
 321           /* Make sure we have a zero-sized array.  */
 322           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 323           return;
 324         }
 325     }
 326   else
 327     {
 328       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 329         runtime_error ("rank of return array incorrect in MINVAL intrinsic");
 330
 331       if (unlikely (compile_options.bounds_check))
 332         {
 333           bounds_ifunction_return ((array_t *) retarray, extent,
 334                                    "return value", "MINVAL");
 335           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 336                                 "MASK argument", "MINVAL");
 337         }
 338     }
 339
 340   for (n = 0; n < rank; n++)
 341     {
 342       count[n] = 0;
 343       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 344       if (extent[n] <= 0)
 345         return;
 346     }
 347
 348   dest = retarray->base_addr;
 349   base = array->base_addr;
 350
 351   while (base)
 352     {
 353       const GFC_REAL_10 * restrict src;
 354       const GFC_LOGICAL_1 * restrict msrc;
 355       GFC_REAL_10 result;
 356       src = base;
 357       msrc = mbase;
 358       {
 359
 360 #if defined (GFC_REAL_10_INFINITY)
 361         result = GFC_REAL_10_INFINITY;
 362 #else
 363         result = GFC_REAL_10_HUGE;
 364 #endif
 365 #if defined (GFC_REAL_10_QUIET_NAN)
 366         int non_empty_p = 0;
 367 #endif
 368         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 369           {
 370
 371 #if defined (GFC_REAL_10_INFINITY) || defined (GFC_REAL_10_QUIET_NAN)
 372                 if (*msrc)
 373                   {
 374 #if defined (GFC_REAL_10_QUIET_NAN)
 375                     non_empty_p = 1;
 376                     if (*src <= result)
 377 #endif
 378                       break;
 379                   }
 380               }
 381             if (unlikely (n >= len))
 382               {
 383 #if defined (GFC_REAL_10_QUIET_NAN)
 384                 result = non_empty_p ? GFC_REAL_10_QUIET_NAN : GFC_REAL_10_HUGE;
 385 #else
 386                 result = GFC_REAL_10_HUGE;
 387 #endif
 388               }
 389             else for (; n < len; n++, src += delta, msrc += mdelta)
 390               {
 391 #endif
 392                 if (*msrc && *src < result)
 393                   result = *src;
 394           }
 395         *dest = result;
 396       }
 397       /* Advance to the next element.  */
 398       count[0]++;
 399       base += sstride[0];
 400       mbase += mstride[0];
 401       dest += dstride[0];
 402       n = 0;
 403       while (count[n] == extent[n])
 404         {
 405           /* When we get to the end of a dimension, reset it and increment
 406              the next dimension.  */
 407           count[n] = 0;
 408           /* We could precalculate these products, but this is a less
 409              frequently used path so probably not worth it.  */
 410           base -= sstride[n] * extent[n];
 411           mbase -= mstride[n] * extent[n];
 412           dest -= dstride[n] * extent[n];
 413           n++;
 414           if (n >= rank)
 415             {
 416               /* Break out of the loop.  */
 417               base = NULL;
 418               break;
 419             }
 420           else
 421             {
 422               count[n]++;
 423               base += sstride[n];
 424               mbase += mstride[n];
 425               dest += dstride[n];
 426             }
 427         }
 428     }
 429 }
 430
 431
 432 extern void sminval_r10 (gfc_array_r10 * const restrict,
 433         gfc_array_r10 * const restrict, const index_type * const restrict,
 434         GFC_LOGICAL_4 *);
 435 export_proto(sminval_r10);
 436
 437 void
 438 sminval_r10 (gfc_array_r10 * const restrict retarray,
 439         gfc_array_r10 * const restrict array,
 440         const index_type * const restrict pdim,
 441         GFC_LOGICAL_4 * mask)
 442 {
 443   index_type count[GFC_MAX_DIMENSIONS];
 444   index_type extent[GFC_MAX_DIMENSIONS];
 445   index_type dstride[GFC_MAX_DIMENSIONS];
 446   GFC_REAL_10 * restrict dest;
 447   index_type rank;
 448   index_type n;
 449   index_type dim;
 450
 451
 452   if (mask == NULL || *mask)
 453     {
 454 #ifdef HAVE_BACK_ARG
 455       minval_r10 (retarray, array, pdim, back);
 456 #else
 457       minval_r10 (retarray, array, pdim);
 458 #endif
 459       return;
 460     }
 461   /* Make dim zero based to avoid confusion.  */
 462   dim = (*pdim) - 1;
 463   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 464
 465   if (unlikely (dim < 0 || dim > rank))
 466     {
 467       runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
 468                      "is %ld, should be between 1 and %ld",
 469                      (long int) dim + 1, (long int) rank + 1);
 470     }
 471
 472   for (n = 0; n < dim; n++)
 473     {
 474       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 475
 476       if (extent[n] <= 0)
 477         extent[n] = 0;
 478     }
 479
 480   for (n = dim; n < rank; n++)
 481     {
 482       extent[n] =
 483         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 484
 485       if (extent[n] <= 0)
 486         extent[n] = 0;
 487     }
 488
 489   if (retarray->base_addr == NULL)
 490     {
 491       size_t alloc_size, str;
 492
 493       for (n = 0; n < rank; n++)
 494         {
 495           if (n == 0)
 496             str = 1;
 497           else
 498             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 499
 500           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 501
 502         }
 503
 504       retarray->offset = 0;
 505       retarray->dtype.rank = rank;
 506
 507       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 508
 509       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
 510       if (alloc_size == 0)
 511         {
 512           /* Make sure we have a zero-sized array.  */
 513           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 514           return;
 515         }
 516     }
 517   else
 518     {
 519       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 520         runtime_error ("rank of return array incorrect in"
 521                        " MINVAL intrinsic: is %ld, should be %ld",
 522                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 523                        (long int) rank);
 524
 525       if (unlikely (compile_options.bounds_check))
 526         {
 527           for (n=0; n < rank; n++)
 528             {
 529               index_type ret_extent;
 530
 531               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 532               if (extent[n] != ret_extent)
 533                 runtime_error ("Incorrect extent in return value of"
 534                                " MINVAL intrinsic in dimension %ld:"
 535                                " is %ld, should be %ld", (long int) n + 1,
 536                                (long int) ret_extent, (long int) extent[n]);
 537             }
 538         }
 539     }
 540
 541   for (n = 0; n < rank; n++)
 542     {
 543       count[n] = 0;
 544       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 545     }
 546
 547   dest = retarray->base_addr;
 548
 549   while(1)
 550     {
 551       *dest = GFC_REAL_10_HUGE;
 552       count[0]++;
 553       dest += dstride[0];
 554       n = 0;
 555       while (count[n] == extent[n])
 556         {
 557           /* When we get to the end of a dimension, reset it and increment
 558              the next dimension.  */
 559           count[n] = 0;
 560           /* We could precalculate these products, but this is a less
 561              frequently used path so probably not worth it.  */
 562           dest -= dstride[n] * extent[n];
 563           n++;
 564           if (n >= rank)
 565             return;
 566           else
 567             {
 568               count[n]++;
 569               dest += dstride[n];
 570             }
 571         }
 572     }
 573 }
 574
 575 #endif