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