libgfortran/generated/maxval_r4.c

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