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