libgfortran/generated/maxval_r4.c

   1 /* Implementation of the MAXVAL intrinsic
   2    Copyright 2002, 2007 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 2 of the License, or (at your option) any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public
  27 License along with libgfortran; see the file COPYING.  If not,
  28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "libgfortran.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34
  35
  36 #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4)
  37
  38
  39 extern void maxval_r4 (gfc_array_r4 * const restrict,
  40         gfc_array_r4 * const restrict, const index_type * const restrict);
  41 export_proto(maxval_r4);
  42
  43 void
  44 maxval_r4 (gfc_array_r4 * const restrict retarray,
  45         gfc_array_r4 * const restrict array,
  46         const index_type * const restrict pdim)
  47 {
  48   index_type count[GFC_MAX_DIMENSIONS];
  49   index_type extent[GFC_MAX_DIMENSIONS];
  50   index_type sstride[GFC_MAX_DIMENSIONS];
  51   index_type dstride[GFC_MAX_DIMENSIONS];
  52   const GFC_REAL_4 * restrict base;
  53   GFC_REAL_4 * restrict dest;
  54   index_type rank;
  55   index_type n;
  56   index_type len;
  57   index_type delta;
  58   index_type dim;
  59   int continue_loop;
  60
  61   /* Make dim zero based to avoid confusion.  */
  62   dim = (*pdim) - 1;
  63   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  64
  65   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  66   if (len < 0)
  67     len = 0;
  68   delta = array->dim[dim].stride;
  69
  70   for (n = 0; n < dim; n++)
  71     {
  72       sstride[n] = array->dim[n].stride;
  73       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  74
  75       if (extent[n] < 0)
  76         extent[n] = 0;
  77     }
  78   for (n = dim; n < rank; n++)
  79     {
  80       sstride[n] = array->dim[n + 1].stride;
  81       extent[n] =
  82         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  83
  84       if (extent[n] < 0)
  85         extent[n] = 0;
  86     }
  87
  88   if (retarray->data == NULL)
  89     {
  90       size_t alloc_size;
  91
  92       for (n = 0; n < rank; n++)
  93         {
  94           retarray->dim[n].lbound = 0;
  95           retarray->dim[n].ubound = extent[n]-1;
  96           if (n == 0)
  97             retarray->dim[n].stride = 1;
  98           else
  99             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 100         }
 101
 102       retarray->offset = 0;
 103       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 104
 105       alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride
 106                    * extent[rank-1];
 107
 108       if (alloc_size == 0)
 109         {
 110           /* Make sure we have a zero-sized array.  */
 111           retarray->dim[0].lbound = 0;
 112           retarray->dim[0].ubound = -1;
 113           return;
 114         }
 115       else
 116         retarray->data = internal_malloc_size (alloc_size);
 117     }
 118   else
 119     {
 120       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 121         runtime_error ("rank of return array incorrect in"
 122                        " MAXVAL intrinsic: is %ld, should be %ld",
 123                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 124                        (long int) rank);
 125
 126       if (compile_options.bounds_check)
 127         {
 128           for (n=0; n < rank; n++)
 129             {
 130               index_type ret_extent;
 131
 132               ret_extent = retarray->dim[n].ubound + 1
 133                 - retarray->dim[n].lbound;
 134               if (extent[n] != ret_extent)
 135                 runtime_error ("Incorrect extent in return value of"
 136                                " MAXVAL intrinsic in dimension %ld:"
 137                                " is %ld, should be %ld", (long int) n + 1,
 138                                (long int) ret_extent, (long int) extent[n]);
 139             }
 140         }
 141     }
 142
 143   for (n = 0; n < rank; n++)
 144     {
 145       count[n] = 0;
 146       dstride[n] = retarray->dim[n].stride;
 147       if (extent[n] <= 0)
 148         len = 0;
 149     }
 150
 151   base = array->data;
 152   dest = retarray->data;
 153
 154   continue_loop = 1;
 155   while (continue_loop)
 156     {
 157       const GFC_REAL_4 * restrict src;
 158       GFC_REAL_4 result;
 159       src = base;
 160       {
 161
 162   result = -GFC_REAL_4_HUGE;
 163         if (len <= 0)
 164           *dest = -GFC_REAL_4_HUGE;
 165         else
 166           {
 167             for (n = 0; n < len; n++, src += delta)
 168               {
 169
 170   if (*src > result)
 171     result = *src;
 172           }
 173             *dest = result;
 174           }
 175       }
 176       /* Advance to the next element.  */
 177       count[0]++;
 178       base += sstride[0];
 179       dest += dstride[0];
 180       n = 0;
 181       while (count[n] == extent[n])
 182         {
 183           /* When we get to the end of a dimension, reset it and increment
 184              the next dimension.  */
 185           count[n] = 0;
 186           /* We could precalculate these products, but this is a less
 187              frequently used path so probably not worth it.  */
 188           base -= sstride[n] * extent[n];
 189           dest -= dstride[n] * extent[n];
 190           n++;
 191           if (n == rank)
 192             {
 193               /* Break out of the look.  */
 194               continue_loop = 0;
 195               break;
 196             }
 197           else
 198             {
 199               count[n]++;
 200               base += sstride[n];
 201               dest += dstride[n];
 202             }
 203         }
 204     }
 205 }
 206
 207
 208 extern void mmaxval_r4 (gfc_array_r4 * const restrict,
 209         gfc_array_r4 * const restrict, const index_type * const restrict,
 210         gfc_array_l1 * const restrict);
 211 export_proto(mmaxval_r4);
 212
 213 void
 214 mmaxval_r4 (gfc_array_r4 * const restrict retarray,
 215         gfc_array_r4 * const restrict array,
 216         const index_type * const restrict pdim,
 217         gfc_array_l1 * const restrict mask)
 218 {
 219   index_type count[GFC_MAX_DIMENSIONS];
 220   index_type extent[GFC_MAX_DIMENSIONS];
 221   index_type sstride[GFC_MAX_DIMENSIONS];
 222   index_type dstride[GFC_MAX_DIMENSIONS];
 223   index_type mstride[GFC_MAX_DIMENSIONS];
 224   GFC_REAL_4 * restrict dest;
 225   const GFC_REAL_4 * restrict base;
 226   const GFC_LOGICAL_1 * restrict mbase;
 227   int rank;
 228   int dim;
 229   index_type n;
 230   index_type len;
 231   index_type delta;
 232   index_type mdelta;
 233   int mask_kind;
 234
 235   dim = (*pdim) - 1;
 236   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 237
 238   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 239   if (len <= 0)
 240     return;
 241
 242   mbase = mask->data;
 243
 244   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 245
 246   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 247 #ifdef HAVE_GFC_LOGICAL_16
 248       || mask_kind == 16
 249 #endif
 250       )
 251     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 252   else
 253     runtime_error ("Funny sized logical array");
 254
 255   delta = array->dim[dim].stride;
 256   mdelta = mask->dim[dim].stride * mask_kind;
 257
 258   for (n = 0; n < dim; n++)
 259     {
 260       sstride[n] = array->dim[n].stride;
 261       mstride[n] = mask->dim[n].stride * mask_kind;
 262       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 263
 264       if (extent[n] < 0)
 265         extent[n] = 0;
 266
 267     }
 268   for (n = dim; n < rank; n++)
 269     {
 270       sstride[n] = array->dim[n + 1].stride;
 271       mstride[n] = mask->dim[n + 1].stride * mask_kind;
 272       extent[n] =
 273         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 274
 275       if (extent[n] < 0)
 276         extent[n] = 0;
 277     }
 278
 279   if (retarray->data == NULL)
 280     {
 281       size_t alloc_size;
 282
 283       for (n = 0; n < rank; n++)
 284         {
 285           retarray->dim[n].lbound = 0;
 286           retarray->dim[n].ubound = extent[n]-1;
 287           if (n == 0)
 288             retarray->dim[n].stride = 1;
 289           else
 290             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 291         }
 292
 293       alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride
 294                    * extent[rank-1];
 295
 296       retarray->offset = 0;
 297       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 298
 299       if (alloc_size == 0)
 300         {
 301           /* Make sure we have a zero-sized array.  */
 302           retarray->dim[0].lbound = 0;
 303           retarray->dim[0].ubound = -1;
 304           return;
 305         }
 306       else
 307         retarray->data = internal_malloc_size (alloc_size);
 308
 309     }
 310   else
 311     {
 312       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 313         runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
 314
 315       if (compile_options.bounds_check)
 316         {
 317           for (n=0; n < rank; n++)
 318             {
 319               index_type ret_extent;
 320
 321               ret_extent = retarray->dim[n].ubound + 1
 322                 - retarray->dim[n].lbound;
 323               if (extent[n] != ret_extent)
 324                 runtime_error ("Incorrect extent in return value of"
 325                                " MAXVAL intrinsic in dimension %ld:"
 326                                " is %ld, should be %ld", (long int) n + 1,
 327                                (long int) ret_extent, (long int) extent[n]);
 328             }
 329           for (n=0; n<= rank; n++)
 330             {
 331               index_type mask_extent, array_extent;
 332
 333               array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
 334               mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
 335               if (array_extent != mask_extent)
 336                 runtime_error ("Incorrect extent in MASK argument of"
 337                                " MAXVAL intrinsic in dimension %ld:"
 338                                " is %ld, should be %ld", (long int) n + 1,
 339                                (long int) mask_extent, (long int) array_extent);
 340             }
 341         }
 342     }
 343
 344   for (n = 0; n < rank; n++)
 345     {
 346       count[n] = 0;
 347       dstride[n] = retarray->dim[n].stride;
 348       if (extent[n] <= 0)
 349         return;
 350     }
 351
 352   dest = retarray->data;
 353   base = array->data;
 354
 355   while (base)
 356     {
 357       const GFC_REAL_4 * restrict src;
 358       const GFC_LOGICAL_1 * restrict msrc;
 359       GFC_REAL_4 result;
 360       src = base;
 361       msrc = mbase;
 362       {
 363
 364   result = -GFC_REAL_4_HUGE;
 365         if (len <= 0)
 366           *dest = -GFC_REAL_4_HUGE;
 367         else
 368           {
 369             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 370               {
 371
 372   if (*msrc && *src > result)
 373     result = *src;
 374               }
 375             *dest = result;
 376           }
 377       }
 378       /* Advance to the next element.  */
 379       count[0]++;
 380       base += sstride[0];
 381       mbase += mstride[0];
 382       dest += dstride[0];
 383       n = 0;
 384       while (count[n] == extent[n])
 385         {
 386           /* When we get to the end of a dimension, reset it and increment
 387              the next dimension.  */
 388           count[n] = 0;
 389           /* We could precalculate these products, but this is a less
 390              frequently used path so probably not worth it.  */
 391           base -= sstride[n] * extent[n];
 392           mbase -= mstride[n] * extent[n];
 393           dest -= dstride[n] * extent[n];
 394           n++;
 395           if (n == rank)
 396             {
 397               /* Break out of the look.  */
 398               base = NULL;
 399               break;
 400             }
 401           else
 402             {
 403               count[n]++;
 404               base += sstride[n];
 405               mbase += mstride[n];
 406               dest += dstride[n];
 407             }
 408         }
 409     }
 410 }
 411
 412
 413 extern void smaxval_r4 (gfc_array_r4 * const restrict,
 414         gfc_array_r4 * const restrict, const index_type * const restrict,
 415         GFC_LOGICAL_4 *);
 416 export_proto(smaxval_r4);
 417
 418 void
 419 smaxval_r4 (gfc_array_r4 * const restrict retarray,
 420         gfc_array_r4 * const restrict array,
 421         const index_type * const restrict pdim,
 422         GFC_LOGICAL_4 * mask)
 423 {
 424   index_type count[GFC_MAX_DIMENSIONS];
 425   index_type extent[GFC_MAX_DIMENSIONS];
 426   index_type sstride[GFC_MAX_DIMENSIONS];
 427   index_type dstride[GFC_MAX_DIMENSIONS];
 428   GFC_REAL_4 * restrict dest;
 429   index_type rank;
 430   index_type n;
 431   index_type dim;
 432
 433
 434   if (*mask)
 435     {
 436       maxval_r4 (retarray, array, pdim);
 437       return;
 438     }
 439   /* Make dim zero based to avoid confusion.  */
 440   dim = (*pdim) - 1;
 441   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 442
 443   for (n = 0; n < dim; n++)
 444     {
 445       sstride[n] = array->dim[n].stride;
 446       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 447
 448       if (extent[n] <= 0)
 449         extent[n] = 0;
 450     }
 451
 452   for (n = dim; n < rank; n++)
 453     {
 454       sstride[n] = array->dim[n + 1].stride;
 455       extent[n] =
 456         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 457
 458       if (extent[n] <= 0)
 459         extent[n] = 0;
 460     }
 461
 462   if (retarray->data == NULL)
 463     {
 464       size_t alloc_size;
 465
 466       for (n = 0; n < rank; n++)
 467         {
 468           retarray->dim[n].lbound = 0;
 469           retarray->dim[n].ubound = extent[n]-1;
 470           if (n == 0)
 471             retarray->dim[n].stride = 1;
 472           else
 473             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 474         }
 475
 476       retarray->offset = 0;
 477       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 478
 479       alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride
 480                    * extent[rank-1];
 481
 482       if (alloc_size == 0)
 483         {
 484           /* Make sure we have a zero-sized array.  */
 485           retarray->dim[0].lbound = 0;
 486           retarray->dim[0].ubound = -1;
 487           return;
 488         }
 489       else
 490         retarray->data = internal_malloc_size (alloc_size);
 491     }
 492   else
 493     {
 494       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 495         runtime_error ("rank of return array incorrect in"
 496                        " MAXVAL intrinsic: is %ld, should be %ld",
 497                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 498                        (long int) rank);
 499
 500       if (compile_options.bounds_check)
 501         {
 502           for (n=0; n < rank; n++)
 503             {
 504               index_type ret_extent;
 505
 506               ret_extent = retarray->dim[n].ubound + 1
 507                 - retarray->dim[n].lbound;
 508               if (extent[n] != ret_extent)
 509                 runtime_error ("Incorrect extent in return value of"
 510                                " MAXVAL intrinsic in dimension %ld:"
 511                                " is %ld, should be %ld", (long int) n + 1,
 512                                (long int) ret_extent, (long int) extent[n]);
 513             }
 514         }
 515     }
 516
 517   for (n = 0; n < rank; n++)
 518     {
 519       count[n] = 0;
 520       dstride[n] = retarray->dim[n].stride;
 521     }
 522
 523   dest = retarray->data;
 524
 525   while(1)
 526     {
 527       *dest = -GFC_REAL_4_HUGE;
 528       count[0]++;
 529       dest += dstride[0];
 530       n = 0;
 531       while (count[n] == extent[n])
 532         {
 533           /* When we get to the end of a dimension, reset it and increment
 534              the next dimension.  */
 535           count[n] = 0;
 536           /* We could precalculate these products, but this is a less
 537              frequently used path so probably not worth it.  */
 538           dest -= dstride[n] * extent[n];
 539           n++;
 540           if (n == rank)
 541             return;
 542           else
 543             {
 544               count[n]++;
 545               dest += dstride[n];
 546             }
 547         }
 548     }
 549 }
 550
 551 #endif