libgfortran/generated/minval_r8.c

   1 /* Implementation of the MINVAL intrinsic
   2    Copyright (C) 2002-2018 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 minval_r8 (gfc_array_r8 * const restrict,
  33         gfc_array_r8 * const restrict, const index_type * const restrict);
  34 export_proto(minval_r8);
  35
  36 void
  37 minval_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 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_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                        " 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_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 mminval_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(mminval_r8);
 214
 215 void
 216 mminval_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   dim = (*pdim) - 1;
 238   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 239
 240
 241   if (unlikely (dim < 0 || dim > rank))
 242     {
 243       runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
 244                      "is %ld, should be between 1 and %ld",
 245                      (long int) dim + 1, (long int) rank + 1);
 246     }
 247
 248   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 249   if (len <= 0)
 250     return;
 251
 252   mbase = mask->base_addr;
 253
 254   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 255
 256   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 257 #ifdef HAVE_GFC_LOGICAL_16
 258       || mask_kind == 16
 259 #endif
 260       )
 261     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 262   else
 263     runtime_error ("Funny sized logical array");
 264
 265   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 266   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 267
 268   for (n = 0; n < dim; n++)
 269     {
 270       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 271       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 272       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 273
 274       if (extent[n] < 0)
 275         extent[n] = 0;
 276
 277     }
 278   for (n = dim; n < rank; n++)
 279     {
 280       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 281       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 282       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 283
 284       if (extent[n] < 0)
 285         extent[n] = 0;
 286     }
 287
 288   if (retarray->base_addr == NULL)
 289     {
 290       size_t alloc_size, str;
 291
 292       for (n = 0; n < rank; n++)
 293         {
 294           if (n == 0)
 295             str = 1;
 296           else
 297             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 298
 299           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 300
 301         }
 302
 303       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 304
 305       retarray->offset = 0;
 306       retarray->dtype.rank = rank;
 307
 308       if (alloc_size == 0)
 309         {
 310           /* Make sure we have a zero-sized array.  */
 311           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 312           return;
 313         }
 314       else
 315         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_8));
 316
 317     }
 318   else
 319     {
 320       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 321         runtime_error ("rank of return array incorrect in MINVAL intrinsic");
 322
 323       if (unlikely (compile_options.bounds_check))
 324         {
 325           bounds_ifunction_return ((array_t *) retarray, extent,
 326                                    "return value", "MINVAL");
 327           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 328                                 "MASK argument", "MINVAL");
 329         }
 330     }
 331
 332   for (n = 0; n < rank; n++)
 333     {
 334       count[n] = 0;
 335       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 336       if (extent[n] <= 0)
 337         return;
 338     }
 339
 340   dest = retarray->base_addr;
 341   base = array->base_addr;
 342
 343   while (base)
 344     {
 345       const GFC_REAL_8 * restrict src;
 346       const GFC_LOGICAL_1 * restrict msrc;
 347       GFC_REAL_8 result;
 348       src = base;
 349       msrc = mbase;
 350       {
 351
 352 #if defined (GFC_REAL_8_INFINITY)
 353         result = GFC_REAL_8_INFINITY;
 354 #else
 355         result = GFC_REAL_8_HUGE;
 356 #endif
 357 #if defined (GFC_REAL_8_QUIET_NAN)
 358         int non_empty_p = 0;
 359 #endif
 360         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 361           {
 362
 363 #if defined (GFC_REAL_8_INFINITY) || defined (GFC_REAL_8_QUIET_NAN)
 364                 if (*msrc)
 365                   {
 366 #if defined (GFC_REAL_8_QUIET_NAN)
 367                     non_empty_p = 1;
 368                     if (*src <= result)
 369 #endif
 370                       break;
 371                   }
 372               }
 373             if (unlikely (n >= len))
 374               {
 375 #if defined (GFC_REAL_8_QUIET_NAN)
 376                 result = non_empty_p ? GFC_REAL_8_QUIET_NAN : GFC_REAL_8_HUGE;
 377 #else
 378                 result = GFC_REAL_8_HUGE;
 379 #endif
 380               }
 381             else for (; n < len; n++, src += delta, msrc += mdelta)
 382               {
 383 #endif
 384                 if (*msrc && *src < result)
 385                   result = *src;
 386           }
 387         *dest = result;
 388       }
 389       /* Advance to the next element.  */
 390       count[0]++;
 391       base += sstride[0];
 392       mbase += mstride[0];
 393       dest += dstride[0];
 394       n = 0;
 395       while (count[n] == extent[n])
 396         {
 397           /* When we get to the end of a dimension, reset it and increment
 398              the next dimension.  */
 399           count[n] = 0;
 400           /* We could precalculate these products, but this is a less
 401              frequently used path so probably not worth it.  */
 402           base -= sstride[n] * extent[n];
 403           mbase -= mstride[n] * extent[n];
 404           dest -= dstride[n] * extent[n];
 405           n++;
 406           if (n >= rank)
 407             {
 408               /* Break out of the loop.  */
 409               base = NULL;
 410               break;
 411             }
 412           else
 413             {
 414               count[n]++;
 415               base += sstride[n];
 416               mbase += mstride[n];
 417               dest += dstride[n];
 418             }
 419         }
 420     }
 421 }
 422
 423
 424 extern void sminval_r8 (gfc_array_r8 * const restrict,
 425         gfc_array_r8 * const restrict, const index_type * const restrict,
 426         GFC_LOGICAL_4 *);
 427 export_proto(sminval_r8);
 428
 429 void
 430 sminval_r8 (gfc_array_r8 * const restrict retarray,
 431         gfc_array_r8 * const restrict array,
 432         const index_type * const restrict pdim,
 433         GFC_LOGICAL_4 * mask)
 434 {
 435   index_type count[GFC_MAX_DIMENSIONS];
 436   index_type extent[GFC_MAX_DIMENSIONS];
 437   index_type dstride[GFC_MAX_DIMENSIONS];
 438   GFC_REAL_8 * restrict dest;
 439   index_type rank;
 440   index_type n;
 441   index_type dim;
 442
 443
 444   if (*mask)
 445     {
 446 #ifdef HAVE_BACK_ARG
 447       minval_r8 (retarray, array, pdim, back);
 448 #else
 449       minval_r8 (retarray, array, pdim);
 450 #endif
 451       return;
 452     }
 453   /* Make dim zero based to avoid confusion.  */
 454   dim = (*pdim) - 1;
 455   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 456
 457   if (unlikely (dim < 0 || dim > rank))
 458     {
 459       runtime_error ("Dim argument incorrect in MINVAL intrinsic: "
 460                      "is %ld, should be between 1 and %ld",
 461                      (long int) dim + 1, (long int) rank + 1);
 462     }
 463
 464   for (n = 0; n < dim; n++)
 465     {
 466       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 467
 468       if (extent[n] <= 0)
 469         extent[n] = 0;
 470     }
 471
 472   for (n = dim; n < rank; n++)
 473     {
 474       extent[n] =
 475         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 476
 477       if (extent[n] <= 0)
 478         extent[n] = 0;
 479     }
 480
 481   if (retarray->base_addr == NULL)
 482     {
 483       size_t alloc_size, str;
 484
 485       for (n = 0; n < rank; n++)
 486         {
 487           if (n == 0)
 488             str = 1;
 489           else
 490             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 491
 492           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 493
 494         }
 495
 496       retarray->offset = 0;
 497       retarray->dtype.rank = rank;
 498
 499       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 500
 501       if (alloc_size == 0)
 502         {
 503           /* Make sure we have a zero-sized array.  */
 504           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 505           return;
 506         }
 507       else
 508         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_8));
 509     }
 510   else
 511     {
 512       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 513         runtime_error ("rank of return array incorrect in"
 514                        " MINVAL intrinsic: is %ld, should be %ld",
 515                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 516                        (long int) rank);
 517
 518       if (unlikely (compile_options.bounds_check))
 519         {
 520           for (n=0; n < rank; n++)
 521             {
 522               index_type ret_extent;
 523
 524               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 525               if (extent[n] != ret_extent)
 526                 runtime_error ("Incorrect extent in return value of"
 527                                " MINVAL intrinsic in dimension %ld:"
 528                                " is %ld, should be %ld", (long int) n + 1,
 529                                (long int) ret_extent, (long int) extent[n]);
 530             }
 531         }
 532     }
 533
 534   for (n = 0; n < rank; n++)
 535     {
 536       count[n] = 0;
 537       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 538     }
 539
 540   dest = retarray->base_addr;
 541
 542   while(1)
 543     {
 544       *dest = GFC_REAL_8_HUGE;
 545       count[0]++;
 546       dest += dstride[0];
 547       n = 0;
 548       while (count[n] == extent[n])
 549         {
 550           /* When we get to the end of a dimension, reset it and increment
 551              the next dimension.  */
 552           count[n] = 0;
 553           /* We could precalculate these products, but this is a less
 554              frequently used path so probably not worth it.  */
 555           dest -= dstride[n] * extent[n];
 556           n++;
 557           if (n >= rank)
 558             return;
 559           else
 560             {
 561               count[n]++;
 562               dest += dstride[n];
 563             }
 564         }
 565     }
 566 }
 567
 568 #endif