libgfortran/generated/maxval_i4.c

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