libgfortran/generated/maxloc1_8_i16.c

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