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