libgfortran/generated/maxloc1_4_r10.c

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