libgfortran/generated/maxloc1_4_r16.c

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