libgfortran/generated/minloc1_4_r16.c

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