libgfortran/generated/maxval_r4.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_4) && defined (HAVE_GFC_REAL_4)
  32
  33
  34 extern void maxval_r4 (gfc_array_r4 * const restrict,
  35         gfc_array_r4 * const restrict, const index_type * const restrict);
  36 export_proto(maxval_r4);
  37
  38 void
  39 maxval_r4 (gfc_array_r4 * const restrict retarray,
  40         gfc_array_r4 * 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_4 * restrict base;
  48   GFC_REAL_4 * 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_4) * 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_4 * restrict src;
 141       GFC_REAL_4 result;
 142       src = base;
 143       {
 144
 145 #if defined (GFC_REAL_4_INFINITY)
 146         result = -GFC_REAL_4_INFINITY;
 147 #else
 148         result = -GFC_REAL_4_HUGE;
 149 #endif
 150         if (len <= 0)
 151           *dest = -GFC_REAL_4_HUGE;
 152         else
 153           {
 154             for (n = 0; n < len; n++, src += delta)
 155               {
 156
 157 #if defined (GFC_REAL_4_QUIET_NAN)
 158                 if (*src >= result)
 159                   break;
 160               }
 161             if (unlikely (n >= len))
 162               result = GFC_REAL_4_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_r4 (gfc_array_r4 * const restrict,
 205         gfc_array_r4 * const restrict, const index_type * const restrict,
 206         gfc_array_l1 * const restrict);
 207 export_proto(mmaxval_r4);
 208
 209 void
 210 mmaxval_r4 (gfc_array_r4 * const restrict retarray,
 211         gfc_array_r4 * 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_4 * restrict dest;
 221   const GFC_REAL_4 * 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_4) * 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_4 * restrict src;
 333       const GFC_LOGICAL_1 * restrict msrc;
 334       GFC_REAL_4 result;
 335       src = base;
 336       msrc = mbase;
 337       {
 338
 339 #if defined (GFC_REAL_4_INFINITY)
 340         result = -GFC_REAL_4_INFINITY;
 341 #else
 342         result = -GFC_REAL_4_HUGE;
 343 #endif
 344 #if defined (GFC_REAL_4_QUIET_NAN)
 345         int non_empty_p = 0;
 346 #endif
 347         if (len <= 0)
 348           *dest = -GFC_REAL_4_HUGE;
 349         else
 350           {
 351             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 352               {
 353
 354 #if defined (GFC_REAL_4_INFINITY) || defined (GFC_REAL_4_QUIET_NAN)
 355                 if (*msrc)
 356                   {
 357 #if defined (GFC_REAL_4_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_4_QUIET_NAN)
 367                 result = non_empty_p ? GFC_REAL_4_QUIET_NAN : -GFC_REAL_4_HUGE;
 368 #else
 369                 result = -GFC_REAL_4_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_r4 (gfc_array_r4 * const restrict,
 417         gfc_array_r4 * const restrict, const index_type * const restrict,
 418         GFC_LOGICAL_4 *);
 419 export_proto(smaxval_r4);
 420
 421 void
 422 smaxval_r4 (gfc_array_r4 * const restrict retarray,
 423         gfc_array_r4 * 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 dstride[GFC_MAX_DIMENSIONS];
 430   GFC_REAL_4 * restrict dest;
 431   index_type rank;
 432   index_type n;
 433   index_type dim;
 434
 435
 436   if (*mask)
 437     {
 438       maxval_r4 (retarray, array, pdim);
 439       return;
 440     }
 441   /* Make dim zero based to avoid confusion.  */
 442   dim = (*pdim) - 1;
 443   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 444
 445   for (n = 0; n < dim; n++)
 446     {
 447       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 448
 449       if (extent[n] <= 0)
 450         extent[n] = 0;
 451     }
 452
 453   for (n = dim; n < rank; n++)
 454     {
 455       extent[n] =
 456         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 457
 458       if (extent[n] <= 0)
 459         extent[n] = 0;
 460     }
 461
 462   if (retarray->data == NULL)
 463     {
 464       size_t alloc_size, str;
 465
 466       for (n = 0; n < rank; n++)
 467         {
 468           if (n == 0)
 469             str = 1;
 470           else
 471             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 472
 473           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 474
 475         }
 476
 477       retarray->offset = 0;
 478       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 479
 480       alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 481                    * extent[rank-1];
 482
 483       if (alloc_size == 0)
 484         {
 485           /* Make sure we have a zero-sized array.  */
 486           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 487           return;
 488         }
 489       else
 490         retarray->data = internal_malloc_size (alloc_size);
 491     }
 492   else
 493     {
 494       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 495         runtime_error ("rank of return array incorrect in"
 496                        " MAXVAL intrinsic: is %ld, should be %ld",
 497                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 498                        (long int) rank);
 499
 500       if (unlikely (compile_options.bounds_check))
 501         {
 502           for (n=0; n < rank; n++)
 503             {
 504               index_type ret_extent;
 505
 506               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 507               if (extent[n] != ret_extent)
 508                 runtime_error ("Incorrect extent in return value of"
 509                                " MAXVAL intrinsic in dimension %ld:"
 510                                " is %ld, should be %ld", (long int) n + 1,
 511                                (long int) ret_extent, (long int) extent[n]);
 512             }
 513         }
 514     }
 515
 516   for (n = 0; n < rank; n++)
 517     {
 518       count[n] = 0;
 519       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 520     }
 521
 522   dest = retarray->data;
 523
 524   while(1)
 525     {
 526       *dest = -GFC_REAL_4_HUGE;
 527       count[0]++;
 528       dest += dstride[0];
 529       n = 0;
 530       while (count[n] == extent[n])
 531         {
 532           /* When we get to the end of a dimension, reset it and increment
 533              the next dimension.  */
 534           count[n] = 0;
 535           /* We could precalculate these products, but this is a less
 536              frequently used path so probably not worth it.  */
 537           dest -= dstride[n] * extent[n];
 538           n++;
 539           if (n == rank)
 540             return;
 541           else
 542             {
 543               count[n]++;
 544               dest += dstride[n];
 545             }
 546         }
 547     }
 548 }
 549
 550 #endif