libgfortran/generated/minval_r16.c

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