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