libgfortran/generated/maxloc1_8_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_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         {
 124           for (n=0; n < rank; n++)
 125             {
 126               index_type ret_extent;
 127
 128               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 129               if (extent[n] != ret_extent)
 130                 runtime_error ("Incorrect extent in return value of"
 131                                " MAXLOC intrinsic in dimension %ld:"
 132                                " is %ld, should be %ld", (long int) n + 1,
 133                                (long int) ret_extent, (long int) extent[n]);
 134             }
 135         }
 136     }
 137
 138   for (n = 0; n < rank; n++)
 139     {
 140       count[n] = 0;
 141       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 142       if (extent[n] <= 0)
 143         len = 0;
 144     }
 145
 146   base = array->data;
 147   dest = retarray->data;
 148
 149   continue_loop = 1;
 150   while (continue_loop)
 151     {
 152       const GFC_REAL_10 * restrict src;
 153       GFC_INTEGER_8 result;
 154       src = base;
 155       {
 156
 157   GFC_REAL_10 maxval;
 158   maxval = -GFC_REAL_10_HUGE;
 159   result = 0;
 160         if (len <= 0)
 161           *dest = 0;
 162         else
 163           {
 164             for (n = 0; n < len; n++, src += delta)
 165               {
 166
 167   if (*src > maxval || !result)
 168     {
 169       maxval = *src;
 170       result = (GFC_INTEGER_8)n + 1;
 171     }
 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 mmaxloc1_8_r10 (gfc_array_i8 * const restrict,
 209         gfc_array_r10 * const restrict, const index_type * const restrict,
 210         gfc_array_l1 * const restrict);
 211 export_proto(mmaxloc1_8_r10);
 212
 213 void
 214 mmaxloc1_8_r10 (gfc_array_i8 * const restrict retarray,
 215         gfc_array_r10 * 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_INTEGER_8 * restrict dest;
 225   const GFC_REAL_10 * 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 = GFC_DESCRIPTOR_EXTENT(array,dim);
 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 = GFC_DESCRIPTOR_STRIDE(array,dim);
 256   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 257
 258   for (n = 0; n < dim; n++)
 259     {
 260       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 261       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 262       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 263
 264       if (extent[n] < 0)
 265         extent[n] = 0;
 266
 267     }
 268   for (n = dim; n < rank; n++)
 269     {
 270       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 271       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 272       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 273
 274       if (extent[n] < 0)
 275         extent[n] = 0;
 276     }
 277
 278   if (retarray->data == NULL)
 279     {
 280       size_t alloc_size, str;
 281
 282       for (n = 0; n < rank; n++)
 283         {
 284           if (n == 0)
 285             str = 1;
 286           else
 287             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 288
 289           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 290
 291         }
 292
 293       alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 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           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 303           return;
 304         }
 305       else
 306         retarray->data = internal_malloc_size (alloc_size);
 307
 308     }
 309   else
 310     {
 311       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 312         runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
 313
 314       if (unlikely (compile_options.bounds_check))
 315         {
 316           for (n=0; n < rank; n++)
 317             {
 318               index_type ret_extent;
 319
 320               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 321               if (extent[n] != ret_extent)
 322                 runtime_error ("Incorrect extent in return value of"
 323                                " MAXLOC intrinsic in dimension %ld:"
 324                                " is %ld, should be %ld", (long int) n + 1,
 325                                (long int) ret_extent, (long int) extent[n]);
 326             }
 327           for (n=0; n<= rank; n++)
 328             {
 329               index_type mask_extent, array_extent;
 330
 331               array_extent = GFC_DESCRIPTOR_EXTENT(array,n);
 332               mask_extent = GFC_DESCRIPTOR_EXTENT(mask,n);
 333               if (array_extent != mask_extent)
 334                 runtime_error ("Incorrect extent in MASK argument of"
 335                                " MAXLOC intrinsic in dimension %ld:"
 336                                " is %ld, should be %ld", (long int) n + 1,
 337                                (long int) mask_extent, (long int) array_extent);
 338             }
 339         }
 340     }
 341
 342   for (n = 0; n < rank; n++)
 343     {
 344       count[n] = 0;
 345       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 346       if (extent[n] <= 0)
 347         return;
 348     }
 349
 350   dest = retarray->data;
 351   base = array->data;
 352
 353   while (base)
 354     {
 355       const GFC_REAL_10 * restrict src;
 356       const GFC_LOGICAL_1 * restrict msrc;
 357       GFC_INTEGER_8 result;
 358       src = base;
 359       msrc = mbase;
 360       {
 361
 362   GFC_REAL_10 maxval;
 363   maxval = -GFC_REAL_10_HUGE;
 364   result = 0;
 365         if (len <= 0)
 366           *dest = 0;
 367         else
 368           {
 369             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 370               {
 371
 372   if (*msrc && (*src > maxval || !result))
 373     {
 374       maxval = *src;
 375       result = (GFC_INTEGER_8)n + 1;
 376     }
 377               }
 378             *dest = result;
 379           }
 380       }
 381       /* Advance to the next element.  */
 382       count[0]++;
 383       base += sstride[0];
 384       mbase += mstride[0];
 385       dest += dstride[0];
 386       n = 0;
 387       while (count[n] == extent[n])
 388         {
 389           /* When we get to the end of a dimension, reset it and increment
 390              the next dimension.  */
 391           count[n] = 0;
 392           /* We could precalculate these products, but this is a less
 393              frequently used path so probably not worth it.  */
 394           base -= sstride[n] * extent[n];
 395           mbase -= mstride[n] * extent[n];
 396           dest -= dstride[n] * extent[n];
 397           n++;
 398           if (n == rank)
 399             {
 400               /* Break out of the look.  */
 401               base = NULL;
 402               break;
 403             }
 404           else
 405             {
 406               count[n]++;
 407               base += sstride[n];
 408               mbase += mstride[n];
 409               dest += dstride[n];
 410             }
 411         }
 412     }
 413 }
 414
 415
 416 extern void smaxloc1_8_r10 (gfc_array_i8 * const restrict,
 417         gfc_array_r10 * const restrict, const index_type * const restrict,
 418         GFC_LOGICAL_4 *);
 419 export_proto(smaxloc1_8_r10);
 420
 421 void
 422 smaxloc1_8_r10 (gfc_array_i8 * const restrict retarray,
 423         gfc_array_r10 * const restrict array,
 424         const index_type * const restrict pdim,
 425         GFC_LOGICAL_4 * mask)
 426 {
 427   index_type count[GFC_MAX_DIMENSIONS];
 428   index_type extent[GFC_MAX_DIMENSIONS];
 429   index_type sstride[GFC_MAX_DIMENSIONS];
 430   index_type dstride[GFC_MAX_DIMENSIONS];
 431   GFC_INTEGER_8 * restrict dest;
 432   index_type rank;
 433   index_type n;
 434   index_type dim;
 435
 436
 437   if (*mask)
 438     {
 439       maxloc1_8_r10 (retarray, array, pdim);
 440       return;
 441     }
 442   /* Make dim zero based to avoid confusion.  */
 443   dim = (*pdim) - 1;
 444   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 445
 446   for (n = 0; n < dim; n++)
 447     {
 448       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 449       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 450
 451       if (extent[n] <= 0)
 452         extent[n] = 0;
 453     }
 454
 455   for (n = dim; n < rank; n++)
 456     {
 457       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 458       extent[n] =
 459         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 460
 461       if (extent[n] <= 0)
 462         extent[n] = 0;
 463     }
 464
 465   if (retarray->data == NULL)
 466     {
 467       size_t alloc_size, str;
 468
 469       for (n = 0; n < rank; n++)
 470         {
 471           if (n == 0)
 472             str = 1;
 473           else
 474             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 475
 476           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 477
 478         }
 479
 480       retarray->offset = 0;
 481       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 482
 483       alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 484                    * extent[rank-1];
 485
 486       if (alloc_size == 0)
 487         {
 488           /* Make sure we have a zero-sized array.  */
 489           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 490           return;
 491         }
 492       else
 493         retarray->data = internal_malloc_size (alloc_size);
 494     }
 495   else
 496     {
 497       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 498         runtime_error ("rank of return array incorrect in"
 499                        " MAXLOC intrinsic: is %ld, should be %ld",
 500                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 501                        (long int) rank);
 502
 503       if (unlikely (compile_options.bounds_check))
 504         {
 505           for (n=0; n < rank; n++)
 506             {
 507               index_type ret_extent;
 508
 509               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 510               if (extent[n] != ret_extent)
 511                 runtime_error ("Incorrect extent in return value of"
 512                                " MAXLOC intrinsic in dimension %ld:"
 513                                " is %ld, should be %ld", (long int) n + 1,
 514                                (long int) ret_extent, (long int) extent[n]);
 515             }
 516         }
 517     }
 518
 519   for (n = 0; n < rank; n++)
 520     {
 521       count[n] = 0;
 522       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 523     }
 524
 525   dest = retarray->data;
 526
 527   while(1)
 528     {
 529       *dest = 0;
 530       count[0]++;
 531       dest += dstride[0];
 532       n = 0;
 533       while (count[n] == extent[n])
 534         {
 535           /* When we get to the end of a dimension, reset it and increment
 536              the next dimension.  */
 537           count[n] = 0;
 538           /* We could precalculate these products, but this is a less
 539              frequently used path so probably not worth it.  */
 540           dest -= dstride[n] * extent[n];
 541           n++;
 542           if (n == rank)
 543             return;
 544           else
 545             {
 546               count[n]++;
 547               dest += dstride[n];
 548             }
 549         }
 550     }
 551 }
 552
 553 #endif