libgfortran/generated/minval_r8.c

   1 /* Implementation of the MINVAL intrinsic
   2    Copyright 2002, 2007, 2009, 2010 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 #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 minval_r8 (gfc_array_r8 * const restrict,
  35         gfc_array_r8 * const restrict, const index_type * const restrict);
  36 export_proto(minval_r8);
  37
  38 void
  39 minval_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->base_addr == 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       retarray->base_addr = xmalloc (alloc_size);
 104       if (alloc_size == 0)
 105         {
 106           /* Make sure we have a zero-sized array.  */
 107           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 108           return;
 109
 110         }
 111     }
 112   else
 113     {
 114       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 115         runtime_error ("rank of return array incorrect in"
 116                        " MINVAL intrinsic: is %ld, should be %ld",
 117                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 118                        (long int) rank);
 119
 120       if (unlikely (compile_options.bounds_check))
 121         bounds_ifunction_return ((array_t *) retarray, extent,
 122                                  "return value", "MINVAL");
 123     }
 124
 125   for (n = 0; n < rank; n++)
 126     {
 127       count[n] = 0;
 128       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 129       if (extent[n] <= 0)
 130         return;
 131     }
 132
 133   base = array->base_addr;
 134   dest = retarray->base_addr;
 135
 136   continue_loop = 1;
 137   while (continue_loop)
 138     {
 139       const GFC_REAL_8 * restrict src;
 140       GFC_REAL_8 result;
 141       src = base;
 142       {
 143
 144 #if defined (GFC_REAL_8_INFINITY)
 145         result = GFC_REAL_8_INFINITY;
 146 #else
 147         result = GFC_REAL_8_HUGE;
 148 #endif
 149         if (len <= 0)
 150           *dest = GFC_REAL_8_HUGE;
 151         else
 152           {
 153             for (n = 0; n < len; n++, src += delta)
 154               {
 155
 156 #if defined (GFC_REAL_8_QUIET_NAN)
 157                 if (*src <= result)
 158                   break;
 159               }
 160             if (unlikely (n >= len))
 161               result = GFC_REAL_8_QUIET_NAN;
 162             else for (; n < len; n++, src += delta)
 163               {
 164 #endif
 165                 if (*src < result)
 166                   result = *src;
 167               }
 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 mminval_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(mminval_r8);
 208
 209 void
 210 mminval_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->base_addr;
 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->base_addr == 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->base_addr = xmalloc (alloc_size);
 303
 304     }
 305   else
 306     {
 307       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 308         runtime_error ("rank of return array incorrect in MINVAL intrinsic");
 309
 310       if (unlikely (compile_options.bounds_check))
 311         {
 312           bounds_ifunction_return ((array_t *) retarray, extent,
 313                                    "return value", "MINVAL");
 314           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 315                                 "MASK argument", "MINVAL");
 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->base_addr;
 328   base = array->base_addr;
 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         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 348           {
 349
 350 #if defined (GFC_REAL_8_INFINITY) || defined (GFC_REAL_8_QUIET_NAN)
 351                 if (*msrc)
 352                   {
 353 #if defined (GFC_REAL_8_QUIET_NAN)
 354                     non_empty_p = 1;
 355                     if (*src <= result)
 356 #endif
 357                       break;
 358                   }
 359               }
 360             if (unlikely (n >= len))
 361               {
 362 #if defined (GFC_REAL_8_QUIET_NAN)
 363                 result = non_empty_p ? GFC_REAL_8_QUIET_NAN : GFC_REAL_8_HUGE;
 364 #else
 365                 result = GFC_REAL_8_HUGE;
 366 #endif
 367               }
 368             else for (; n < len; n++, src += delta, msrc += mdelta)
 369               {
 370 #endif
 371                 if (*msrc && *src < result)
 372                   result = *src;
 373           }
 374         *dest = result;
 375       }
 376       /* Advance to the next element.  */
 377       count[0]++;
 378       base += sstride[0];
 379       mbase += mstride[0];
 380       dest += dstride[0];
 381       n = 0;
 382       while (count[n] == extent[n])
 383         {
 384           /* When we get to the end of a dimension, reset it and increment
 385              the next dimension.  */
 386           count[n] = 0;
 387           /* We could precalculate these products, but this is a less
 388              frequently used path so probably not worth it.  */
 389           base -= sstride[n] * extent[n];
 390           mbase -= mstride[n] * extent[n];
 391           dest -= dstride[n] * extent[n];
 392           n++;
 393           if (n == rank)
 394             {
 395               /* Break out of the look.  */
 396               base = NULL;
 397               break;
 398             }
 399           else
 400             {
 401               count[n]++;
 402               base += sstride[n];
 403               mbase += mstride[n];
 404               dest += dstride[n];
 405             }
 406         }
 407     }
 408 }
 409
 410
 411 extern void sminval_r8 (gfc_array_r8 * const restrict,
 412         gfc_array_r8 * const restrict, const index_type * const restrict,
 413         GFC_LOGICAL_4 *);
 414 export_proto(sminval_r8);
 415
 416 void
 417 sminval_r8 (gfc_array_r8 * const restrict retarray,
 418         gfc_array_r8 * const restrict array,
 419         const index_type * const restrict pdim,
 420         GFC_LOGICAL_4 * mask)
 421 {
 422   index_type count[GFC_MAX_DIMENSIONS];
 423   index_type extent[GFC_MAX_DIMENSIONS];
 424   index_type dstride[GFC_MAX_DIMENSIONS];
 425   GFC_REAL_8 * restrict dest;
 426   index_type rank;
 427   index_type n;
 428   index_type dim;
 429
 430
 431   if (*mask)
 432     {
 433       minval_r8 (retarray, array, pdim);
 434       return;
 435     }
 436   /* Make dim zero based to avoid confusion.  */
 437   dim = (*pdim) - 1;
 438   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 439
 440   for (n = 0; n < dim; n++)
 441     {
 442       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 443
 444       if (extent[n] <= 0)
 445         extent[n] = 0;
 446     }
 447
 448   for (n = dim; n < rank; n++)
 449     {
 450       extent[n] =
 451         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 452
 453       if (extent[n] <= 0)
 454         extent[n] = 0;
 455     }
 456
 457   if (retarray->base_addr == NULL)
 458     {
 459       size_t alloc_size, str;
 460
 461       for (n = 0; n < rank; n++)
 462         {
 463           if (n == 0)
 464             str = 1;
 465           else
 466             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 467
 468           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 469
 470         }
 471
 472       retarray->offset = 0;
 473       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 474
 475       alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 476                    * extent[rank-1];
 477
 478       if (alloc_size == 0)
 479         {
 480           /* Make sure we have a zero-sized array.  */
 481           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 482           return;
 483         }
 484       else
 485         retarray->base_addr = xmalloc (alloc_size);
 486     }
 487   else
 488     {
 489       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 490         runtime_error ("rank of return array incorrect in"
 491                        " MINVAL intrinsic: is %ld, should be %ld",
 492                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 493                        (long int) rank);
 494
 495       if (unlikely (compile_options.bounds_check))
 496         {
 497           for (n=0; n < rank; n++)
 498             {
 499               index_type ret_extent;
 500
 501               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 502               if (extent[n] != ret_extent)
 503                 runtime_error ("Incorrect extent in return value of"
 504                                " MINVAL intrinsic in dimension %ld:"
 505                                " is %ld, should be %ld", (long int) n + 1,
 506                                (long int) ret_extent, (long int) extent[n]);
 507             }
 508         }
 509     }
 510
 511   for (n = 0; n < rank; n++)
 512     {
 513       count[n] = 0;
 514       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 515     }
 516
 517   dest = retarray->base_addr;
 518
 519   while(1)
 520     {
 521       *dest = GFC_REAL_8_HUGE;
 522       count[0]++;
 523       dest += dstride[0];
 524       n = 0;
 525       while (count[n] == extent[n])
 526         {
 527           /* When we get to the end of a dimension, reset it and increment
 528              the next dimension.  */
 529           count[n] = 0;
 530           /* We could precalculate these products, but this is a less
 531              frequently used path so probably not worth it.  */
 532           dest -= dstride[n] * extent[n];
 533           n++;
 534           if (n == rank)
 535             return;
 536           else
 537             {
 538               count[n]++;
 539               dest += dstride[n];
 540             }
 541         }
 542     }
 543 }
 544
 545 #endif