libgfortran/generated/maxloc1_4_r10.c

   1 /* Implementation of the MAXLOC intrinsic
   2    Copyright 2002, 2007, 2009 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 95 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_4)
  33
  34
  35 extern void maxloc1_4_r10 (gfc_array_i4 * const restrict,
  36         gfc_array_r10 * const restrict, const index_type * const restrict);
  37 export_proto(maxloc1_4_r10);
  38
  39 void
  40 maxloc1_4_r10 (gfc_array_i4 * 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_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->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_4) * 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_4 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_4)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_4)n + 1;
 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_r10 (gfc_array_i4 * const restrict,
 213         gfc_array_r10 * const restrict, const index_type * const restrict,
 214         gfc_array_l1 * const restrict);
 215 export_proto(mmaxloc1_4_r10);
 216
 217 void
 218 mmaxloc1_4_r10 (gfc_array_i4 * const restrict retarray,
 219         gfc_array_r10 * 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_10 * 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->data;
 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->data == 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->data = internal_malloc_size (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->data;
 336   base = array->data;
 337
 338   while (base)
 339     {
 340       const GFC_REAL_10 * 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_10 maxval;
 348 #if defined (GFC_REAL_10_INFINITY)
 349         maxval = -GFC_REAL_10_INFINITY;
 350 #else
 351         maxval = -GFC_REAL_10_HUGE;
 352 #endif
 353 #if defined (GFC_REAL_10_QUIET_NAN)
 354         GFC_INTEGER_4 result2 = 0;
 355 #endif
 356         result = 0;
 357         if (len <= 0)
 358           *dest = 0;
 359         else
 360           {
 361             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 362               {
 363
 364                 if (*msrc)
 365                   {
 366 #if defined (GFC_REAL_10_QUIET_NAN)
 367                     if (!result2)
 368                       result2 = (GFC_INTEGER_4)n + 1;
 369                     if (*src >= maxval)
 370 #endif
 371                       {
 372                         maxval = *src;
 373                         result = (GFC_INTEGER_4)n + 1;
 374                         break;
 375                       }
 376                   }
 377               }
 378 #if defined (GFC_REAL_10_QUIET_NAN)
 379             if (unlikely (n >= len))
 380               result = result2;
 381             else
 382 #endif
 383             for (; n < len; n++, src += delta, msrc += mdelta)
 384               {
 385                 if (*msrc && *src > maxval)
 386                   {
 387                     maxval = *src;
 388                     result = (GFC_INTEGER_4)n + 1;
 389                   }
 390               }
 391             *dest = result;
 392           }
 393       }
 394       /* Advance to the next element.  */
 395       count[0]++;
 396       base += sstride[0];
 397       mbase += mstride[0];
 398       dest += dstride[0];
 399       n = 0;
 400       while (count[n] == extent[n])
 401         {
 402           /* When we get to the end of a dimension, reset it and increment
 403              the next dimension.  */
 404           count[n] = 0;
 405           /* We could precalculate these products, but this is a less
 406              frequently used path so probably not worth it.  */
 407           base -= sstride[n] * extent[n];
 408           mbase -= mstride[n] * extent[n];
 409           dest -= dstride[n] * extent[n];
 410           n++;
 411           if (n == rank)
 412             {
 413               /* Break out of the look.  */
 414               base = NULL;
 415               break;
 416             }
 417           else
 418             {
 419               count[n]++;
 420               base += sstride[n];
 421               mbase += mstride[n];
 422               dest += dstride[n];
 423             }
 424         }
 425     }
 426 }
 427
 428
 429 extern void smaxloc1_4_r10 (gfc_array_i4 * const restrict,
 430         gfc_array_r10 * const restrict, const index_type * const restrict,
 431         GFC_LOGICAL_4 *);
 432 export_proto(smaxloc1_4_r10);
 433
 434 void
 435 smaxloc1_4_r10 (gfc_array_i4 * const restrict retarray,
 436         gfc_array_r10 * const restrict array,
 437         const index_type * const restrict pdim,
 438         GFC_LOGICAL_4 * mask)
 439 {
 440   index_type count[GFC_MAX_DIMENSIONS];
 441   index_type extent[GFC_MAX_DIMENSIONS];
 442   index_type sstride[GFC_MAX_DIMENSIONS];
 443   index_type dstride[GFC_MAX_DIMENSIONS];
 444   GFC_INTEGER_4 * restrict dest;
 445   index_type rank;
 446   index_type n;
 447   index_type dim;
 448
 449
 450   if (*mask)
 451     {
 452       maxloc1_4_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       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 462       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 463
 464       if (extent[n] <= 0)
 465         extent[n] = 0;
 466     }
 467
 468   for (n = dim; n < rank; n++)
 469     {
 470       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 471       extent[n] =
 472         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 473
 474       if (extent[n] <= 0)
 475         extent[n] = 0;
 476     }
 477
 478   if (retarray->data == NULL)
 479     {
 480       size_t alloc_size, str;
 481
 482       for (n = 0; n < rank; n++)
 483         {
 484           if (n == 0)
 485             str = 1;
 486           else
 487             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 488
 489           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 490
 491         }
 492
 493       retarray->offset = 0;
 494       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 495
 496       alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 497                    * extent[rank-1];
 498
 499       if (alloc_size == 0)
 500         {
 501           /* Make sure we have a zero-sized array.  */
 502           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 503           return;
 504         }
 505       else
 506         retarray->data = internal_malloc_size (alloc_size);
 507     }
 508   else
 509     {
 510       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 511         runtime_error ("rank of return array incorrect in"
 512                        " MAXLOC intrinsic: is %ld, should be %ld",
 513                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 514                        (long int) rank);
 515
 516       if (unlikely (compile_options.bounds_check))
 517         {
 518           for (n=0; n < rank; n++)
 519             {
 520               index_type ret_extent;
 521
 522               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 523               if (extent[n] != ret_extent)
 524                 runtime_error ("Incorrect extent in return value of"
 525                                " MAXLOC intrinsic in dimension %ld:"
 526                                " is %ld, should be %ld", (long int) n + 1,
 527                                (long int) ret_extent, (long int) extent[n]);
 528             }
 529         }
 530     }
 531
 532   for (n = 0; n < rank; n++)
 533     {
 534       count[n] = 0;
 535       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 536     }
 537
 538   dest = retarray->data;
 539
 540   while(1)
 541     {
 542       *dest = 0;
 543       count[0]++;
 544       dest += dstride[0];
 545       n = 0;
 546       while (count[n] == extent[n])
 547         {
 548           /* When we get to the end of a dimension, reset it and increment
 549              the next dimension.  */
 550           count[n] = 0;
 551           /* We could precalculate these products, but this is a less
 552              frequently used path so probably not worth it.  */
 553           dest -= dstride[n] * extent[n];
 554           n++;
 555           if (n == rank)
 556             return;
 557           else
 558             {
 559               count[n]++;
 560               dest += dstride[n];
 561             }
 562         }
 563     }
 564 }
 565
 566 #endif