libgfortran/generated/minval_r10.c

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