libgfortran/generated/maxloc1_8_r10.c

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