libgfortran/generated/minval_r4.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_4) && defined (HAVE_GFC_REAL_4)
  32
  33
  34 extern void minval_r4 (gfc_array_r4 * const restrict,
  35         gfc_array_r4 * const restrict, const index_type * const restrict);
  36 export_proto(minval_r4);
  37
  38 void
  39 minval_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                        " MINVAL 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", "MINVAL");
 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
 170             *dest = result;
 171           }
 172       }
 173       /* Advance to the next element.  */
 174       count[0]++;
 175       base += sstride[0];
 176       dest += dstride[0];
 177       n = 0;
 178       while (count[n] == extent[n])
 179         {
 180           /* When we get to the end of a dimension, reset it and increment
 181              the next dimension.  */
 182           count[n] = 0;
 183           /* We could precalculate these products, but this is a less
 184              frequently used path so probably not worth it.  */
 185           base -= sstride[n] * extent[n];
 186           dest -= dstride[n] * extent[n];
 187           n++;
 188           if (n == rank)
 189             {
 190               /* Break out of the look.  */
 191               continue_loop = 0;
 192               break;
 193             }
 194           else
 195             {
 196               count[n]++;
 197               base += sstride[n];
 198               dest += dstride[n];
 199             }
 200         }
 201     }
 202 }
 203
 204
 205 extern void mminval_r4 (gfc_array_r4 * const restrict,
 206         gfc_array_r4 * const restrict, const index_type * const restrict,
 207         gfc_array_l1 * const restrict);
 208 export_proto(mminval_r4);
 209
 210 void
 211 mminval_r4 (gfc_array_r4 * const restrict retarray,
 212         gfc_array_r4 * const restrict array,
 213         const index_type * const restrict pdim,
 214         gfc_array_l1 * const restrict mask)
 215 {
 216   index_type count[GFC_MAX_DIMENSIONS];
 217   index_type extent[GFC_MAX_DIMENSIONS];
 218   index_type sstride[GFC_MAX_DIMENSIONS];
 219   index_type dstride[GFC_MAX_DIMENSIONS];
 220   index_type mstride[GFC_MAX_DIMENSIONS];
 221   GFC_REAL_4 * restrict dest;
 222   const GFC_REAL_4 * restrict base;
 223   const GFC_LOGICAL_1 * restrict mbase;
 224   int rank;
 225   int dim;
 226   index_type n;
 227   index_type len;
 228   index_type delta;
 229   index_type mdelta;
 230   int mask_kind;
 231
 232   dim = (*pdim) - 1;
 233   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 234
 235   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 236   if (len <= 0)
 237     return;
 238
 239   mbase = mask->data;
 240
 241   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 242
 243   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 244 #ifdef HAVE_GFC_LOGICAL_16
 245       || mask_kind == 16
 246 #endif
 247       )
 248     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 249   else
 250     runtime_error ("Funny sized logical array");
 251
 252   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 253   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 254
 255   for (n = 0; n < dim; n++)
 256     {
 257       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 258       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 259       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 260
 261       if (extent[n] < 0)
 262         extent[n] = 0;
 263
 264     }
 265   for (n = dim; n < rank; n++)
 266     {
 267       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 268       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 269       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 270
 271       if (extent[n] < 0)
 272         extent[n] = 0;
 273     }
 274
 275   if (retarray->data == NULL)
 276     {
 277       size_t alloc_size, str;
 278
 279       for (n = 0; n < rank; n++)
 280         {
 281           if (n == 0)
 282             str = 1;
 283           else
 284             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 285
 286           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 287
 288         }
 289
 290       alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 291                    * extent[rank-1];
 292
 293       retarray->offset = 0;
 294       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 295
 296       if (alloc_size == 0)
 297         {
 298           /* Make sure we have a zero-sized array.  */
 299           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 300           return;
 301         }
 302       else
 303         retarray->data = internal_malloc_size (alloc_size);
 304
 305     }
 306   else
 307     {
 308       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 309         runtime_error ("rank of return array incorrect in MINVAL intrinsic");
 310
 311       if (unlikely (compile_options.bounds_check))
 312         {
 313           bounds_ifunction_return ((array_t *) retarray, extent,
 314                                    "return value", "MINVAL");
 315           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 316                                 "MASK argument", "MINVAL");
 317         }
 318     }
 319
 320   for (n = 0; n < rank; n++)
 321     {
 322       count[n] = 0;
 323       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 324       if (extent[n] <= 0)
 325         return;
 326     }
 327
 328   dest = retarray->data;
 329   base = array->data;
 330
 331   while (base)
 332     {
 333       const GFC_REAL_4 * restrict src;
 334       const GFC_LOGICAL_1 * restrict msrc;
 335       GFC_REAL_4 result;
 336       src = base;
 337       msrc = mbase;
 338       {
 339
 340 #if defined (GFC_REAL_4_INFINITY)
 341         result = GFC_REAL_4_INFINITY;
 342 #else
 343         result = GFC_REAL_4_HUGE;
 344 #endif
 345 #if defined (GFC_REAL_4_QUIET_NAN)
 346         int non_empty_p = 0;
 347 #endif
 348         if (len <= 0)
 349           *dest = GFC_REAL_4_HUGE;
 350         else
 351           {
 352             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 353               {
 354
 355 #if defined (GFC_REAL_4_INFINITY) || defined (GFC_REAL_4_QUIET_NAN)
 356                 if (*msrc)
 357                   {
 358 #if defined (GFC_REAL_4_QUIET_NAN)
 359                     non_empty_p = 1;
 360                     if (*src <= result)
 361 #endif
 362                       break;
 363                   }
 364               }
 365             if (unlikely (n >= len))
 366               {
 367 #if defined (GFC_REAL_4_QUIET_NAN)
 368                 result = non_empty_p ? GFC_REAL_4_QUIET_NAN : GFC_REAL_4_HUGE;
 369 #else
 370                 result = GFC_REAL_4_HUGE;
 371 #endif
 372               }
 373             else for (; n < len; n++, src += delta, msrc += mdelta)
 374               {
 375 #endif
 376                 if (*msrc && *src < result)
 377                   result = *src;
 378               }
 379             *dest = result;
 380           }
 381       }
 382       /* Advance to the next element.  */
 383       count[0]++;
 384       base += sstride[0];
 385       mbase += mstride[0];
 386       dest += dstride[0];
 387       n = 0;
 388       while (count[n] == extent[n])
 389         {
 390           /* When we get to the end of a dimension, reset it and increment
 391              the next dimension.  */
 392           count[n] = 0;
 393           /* We could precalculate these products, but this is a less
 394              frequently used path so probably not worth it.  */
 395           base -= sstride[n] * extent[n];
 396           mbase -= mstride[n] * extent[n];
 397           dest -= dstride[n] * extent[n];
 398           n++;
 399           if (n == rank)
 400             {
 401               /* Break out of the look.  */
 402               base = NULL;
 403               break;
 404             }
 405           else
 406             {
 407               count[n]++;
 408               base += sstride[n];
 409               mbase += mstride[n];
 410               dest += dstride[n];
 411             }
 412         }
 413     }
 414 }
 415
 416
 417 extern void sminval_r4 (gfc_array_r4 * const restrict,
 418         gfc_array_r4 * const restrict, const index_type * const restrict,
 419         GFC_LOGICAL_4 *);
 420 export_proto(sminval_r4);
 421
 422 void
 423 sminval_r4 (gfc_array_r4 * const restrict retarray,
 424         gfc_array_r4 * const restrict array,
 425         const index_type * const restrict pdim,
 426         GFC_LOGICAL_4 * mask)
 427 {
 428   index_type count[GFC_MAX_DIMENSIONS];
 429   index_type extent[GFC_MAX_DIMENSIONS];
 430   index_type dstride[GFC_MAX_DIMENSIONS];
 431   GFC_REAL_4 * restrict dest;
 432   index_type rank;
 433   index_type n;
 434   index_type dim;
 435
 436
 437   if (*mask)
 438     {
 439       minval_r4 (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       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 449
 450       if (extent[n] <= 0)
 451         extent[n] = 0;
 452     }
 453
 454   for (n = dim; n < rank; n++)
 455     {
 456       extent[n] =
 457         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 458
 459       if (extent[n] <= 0)
 460         extent[n] = 0;
 461     }
 462
 463   if (retarray->data == NULL)
 464     {
 465       size_t alloc_size, str;
 466
 467       for (n = 0; n < rank; n++)
 468         {
 469           if (n == 0)
 470             str = 1;
 471           else
 472             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 473
 474           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 475
 476         }
 477
 478       retarray->offset = 0;
 479       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 480
 481       alloc_size = sizeof (GFC_REAL_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 482                    * extent[rank-1];
 483
 484       if (alloc_size == 0)
 485         {
 486           /* Make sure we have a zero-sized array.  */
 487           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 488           return;
 489         }
 490       else
 491         retarray->data = internal_malloc_size (alloc_size);
 492     }
 493   else
 494     {
 495       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 496         runtime_error ("rank of return array incorrect in"
 497                        " MINVAL intrinsic: is %ld, should be %ld",
 498                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 499                        (long int) rank);
 500
 501       if (unlikely (compile_options.bounds_check))
 502         {
 503           for (n=0; n < rank; n++)
 504             {
 505               index_type ret_extent;
 506
 507               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 508               if (extent[n] != ret_extent)
 509                 runtime_error ("Incorrect extent in return value of"
 510                                " MINVAL intrinsic in dimension %ld:"
 511                                " is %ld, should be %ld", (long int) n + 1,
 512                                (long int) ret_extent, (long int) extent[n]);
 513             }
 514         }
 515     }
 516
 517   for (n = 0; n < rank; n++)
 518     {
 519       count[n] = 0;
 520       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 521     }
 522
 523   dest = retarray->data;
 524
 525   while(1)
 526     {
 527       *dest = GFC_REAL_4_HUGE;
 528       count[0]++;
 529       dest += dstride[0];
 530       n = 0;
 531       while (count[n] == extent[n])
 532         {
 533           /* When we get to the end of a dimension, reset it and increment
 534              the next dimension.  */
 535           count[n] = 0;
 536           /* We could precalculate these products, but this is a less
 537              frequently used path so probably not worth it.  */
 538           dest -= dstride[n] * extent[n];
 539           n++;
 540           if (n == rank)
 541             return;
 542           else
 543             {
 544               count[n]++;
 545               dest += dstride[n];
 546             }
 547         }
 548     }
 549 }
 550
 551 #endif