libgfortran/generated/maxval_r8.c

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