libgfortran/generated/product_r10.c

   1 /* Implementation of the PRODUCT intrinsic
   2    Copyright (C) 2002-2017 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4
   5 This file is part of the GNU Fortran 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
  28
  29 #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10)
  30
  31
  32 extern void product_r10 (gfc_array_r10 * const restrict,
  33         gfc_array_r10 * const restrict, const index_type * const restrict);
  34 export_proto(product_r10);
  35
  36 void
  37 product_r10 (gfc_array_r10 * const restrict retarray,
  38         gfc_array_r10 * const restrict array,
  39         const index_type * const restrict pdim)
  40 {
  41   index_type count[GFC_MAX_DIMENSIONS];
  42   index_type extent[GFC_MAX_DIMENSIONS];
  43   index_type sstride[GFC_MAX_DIMENSIONS];
  44   index_type dstride[GFC_MAX_DIMENSIONS];
  45   const GFC_REAL_10 * restrict base;
  46   GFC_REAL_10 * restrict dest;
  47   index_type rank;
  48   index_type n;
  49   index_type len;
  50   index_type delta;
  51   index_type dim;
  52   int continue_loop;
  53
  54   /* Make dim zero based to avoid confusion.  */
  55   dim = (*pdim) - 1;
  56   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  57
  58   len = GFC_DESCRIPTOR_EXTENT(array,dim);
  59   if (len < 0)
  60     len = 0;
  61   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  62
  63   for (n = 0; n < dim; n++)
  64     {
  65       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  66       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  67
  68       if (extent[n] < 0)
  69         extent[n] = 0;
  70     }
  71   for (n = dim; n < rank; n++)
  72     {
  73       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
  74       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
  75
  76       if (extent[n] < 0)
  77         extent[n] = 0;
  78     }
  79
  80   if (retarray->base_addr == NULL)
  81     {
  82       size_t alloc_size, str;
  83
  84       for (n = 0; n < rank; n++)
  85         {
  86           if (n == 0)
  87             str = 1;
  88           else
  89             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
  90
  91           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
  92
  93         }
  94
  95       retarray->offset = 0;
  96       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
  97
  98       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
  99
 100       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
 101       if (alloc_size == 0)
 102         {
 103           /* Make sure we have a zero-sized array.  */
 104           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 105           return;
 106
 107         }
 108     }
 109   else
 110     {
 111       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 112         runtime_error ("rank of return array incorrect in"
 113                        " PRODUCT intrinsic: is %ld, should be %ld",
 114                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 115                        (long int) rank);
 116
 117       if (unlikely (compile_options.bounds_check))
 118         bounds_ifunction_return ((array_t *) retarray, extent,
 119                                  "return value", "PRODUCT");
 120     }
 121
 122   for (n = 0; n < rank; n++)
 123     {
 124       count[n] = 0;
 125       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 126       if (extent[n] <= 0)
 127         return;
 128     }
 129
 130   base = array->base_addr;
 131   dest = retarray->base_addr;
 132
 133   continue_loop = 1;
 134   while (continue_loop)
 135     {
 136       const GFC_REAL_10 * restrict src;
 137       GFC_REAL_10 result;
 138       src = base;
 139       {
 140
 141   result = 1;
 142         if (len <= 0)
 143           *dest = 1;
 144         else
 145           {
 146             for (n = 0; n < len; n++, src += delta)
 147               {
 148
 149   result *= *src;
 150               }
 151
 152             *dest = result;
 153           }
 154       }
 155       /* Advance to the next element.  */
 156       count[0]++;
 157       base += sstride[0];
 158       dest += dstride[0];
 159       n = 0;
 160       while (count[n] == extent[n])
 161         {
 162           /* When we get to the end of a dimension, reset it and increment
 163              the next dimension.  */
 164           count[n] = 0;
 165           /* We could precalculate these products, but this is a less
 166              frequently used path so probably not worth it.  */
 167           base -= sstride[n] * extent[n];
 168           dest -= dstride[n] * extent[n];
 169           n++;
 170           if (n >= rank)
 171             {
 172               /* Break out of the loop.  */
 173               continue_loop = 0;
 174               break;
 175             }
 176           else
 177             {
 178               count[n]++;
 179               base += sstride[n];
 180               dest += dstride[n];
 181             }
 182         }
 183     }
 184 }
 185
 186
 187 extern void mproduct_r10 (gfc_array_r10 * const restrict,
 188         gfc_array_r10 * const restrict, const index_type * const restrict,
 189         gfc_array_l1 * const restrict);
 190 export_proto(mproduct_r10);
 191
 192 void
 193 mproduct_r10 (gfc_array_r10 * const restrict retarray,
 194         gfc_array_r10 * const restrict array,
 195         const index_type * const restrict pdim,
 196         gfc_array_l1 * const restrict mask)
 197 {
 198   index_type count[GFC_MAX_DIMENSIONS];
 199   index_type extent[GFC_MAX_DIMENSIONS];
 200   index_type sstride[GFC_MAX_DIMENSIONS];
 201   index_type dstride[GFC_MAX_DIMENSIONS];
 202   index_type mstride[GFC_MAX_DIMENSIONS];
 203   GFC_REAL_10 * restrict dest;
 204   const GFC_REAL_10 * restrict base;
 205   const GFC_LOGICAL_1 * restrict mbase;
 206   int rank;
 207   int dim;
 208   index_type n;
 209   index_type len;
 210   index_type delta;
 211   index_type mdelta;
 212   int mask_kind;
 213
 214   dim = (*pdim) - 1;
 215   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 216
 217   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 218   if (len <= 0)
 219     return;
 220
 221   mbase = mask->base_addr;
 222
 223   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 224
 225   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 226 #ifdef HAVE_GFC_LOGICAL_16
 227       || mask_kind == 16
 228 #endif
 229       )
 230     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 231   else
 232     runtime_error ("Funny sized logical array");
 233
 234   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 235   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 236
 237   for (n = 0; n < dim; n++)
 238     {
 239       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 240       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 241       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 242
 243       if (extent[n] < 0)
 244         extent[n] = 0;
 245
 246     }
 247   for (n = dim; n < rank; n++)
 248     {
 249       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 250       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 251       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 252
 253       if (extent[n] < 0)
 254         extent[n] = 0;
 255     }
 256
 257   if (retarray->base_addr == NULL)
 258     {
 259       size_t alloc_size, str;
 260
 261       for (n = 0; n < rank; n++)
 262         {
 263           if (n == 0)
 264             str = 1;
 265           else
 266             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 267
 268           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 269
 270         }
 271
 272       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 273
 274       retarray->offset = 0;
 275       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 276
 277       if (alloc_size == 0)
 278         {
 279           /* Make sure we have a zero-sized array.  */
 280           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 281           return;
 282         }
 283       else
 284         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
 285
 286     }
 287   else
 288     {
 289       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 290         runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
 291
 292       if (unlikely (compile_options.bounds_check))
 293         {
 294           bounds_ifunction_return ((array_t *) retarray, extent,
 295                                    "return value", "PRODUCT");
 296           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 297                                 "MASK argument", "PRODUCT");
 298         }
 299     }
 300
 301   for (n = 0; n < rank; n++)
 302     {
 303       count[n] = 0;
 304       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 305       if (extent[n] <= 0)
 306         return;
 307     }
 308
 309   dest = retarray->base_addr;
 310   base = array->base_addr;
 311
 312   while (base)
 313     {
 314       const GFC_REAL_10 * restrict src;
 315       const GFC_LOGICAL_1 * restrict msrc;
 316       GFC_REAL_10 result;
 317       src = base;
 318       msrc = mbase;
 319       {
 320
 321   result = 1;
 322         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 323           {
 324
 325   if (*msrc)
 326     result *= *src;
 327           }
 328         *dest = result;
 329       }
 330       /* Advance to the next element.  */
 331       count[0]++;
 332       base += sstride[0];
 333       mbase += mstride[0];
 334       dest += dstride[0];
 335       n = 0;
 336       while (count[n] == extent[n])
 337         {
 338           /* When we get to the end of a dimension, reset it and increment
 339              the next dimension.  */
 340           count[n] = 0;
 341           /* We could precalculate these products, but this is a less
 342              frequently used path so probably not worth it.  */
 343           base -= sstride[n] * extent[n];
 344           mbase -= mstride[n] * extent[n];
 345           dest -= dstride[n] * extent[n];
 346           n++;
 347           if (n >= rank)
 348             {
 349               /* Break out of the loop.  */
 350               base = NULL;
 351               break;
 352             }
 353           else
 354             {
 355               count[n]++;
 356               base += sstride[n];
 357               mbase += mstride[n];
 358               dest += dstride[n];
 359             }
 360         }
 361     }
 362 }
 363
 364
 365 extern void sproduct_r10 (gfc_array_r10 * const restrict,
 366         gfc_array_r10 * const restrict, const index_type * const restrict,
 367         GFC_LOGICAL_4 *);
 368 export_proto(sproduct_r10);
 369
 370 void
 371 sproduct_r10 (gfc_array_r10 * const restrict retarray,
 372         gfc_array_r10 * const restrict array,
 373         const index_type * const restrict pdim,
 374         GFC_LOGICAL_4 * mask)
 375 {
 376   index_type count[GFC_MAX_DIMENSIONS];
 377   index_type extent[GFC_MAX_DIMENSIONS];
 378   index_type dstride[GFC_MAX_DIMENSIONS];
 379   GFC_REAL_10 * restrict dest;
 380   index_type rank;
 381   index_type n;
 382   index_type dim;
 383
 384
 385   if (*mask)
 386     {
 387       product_r10 (retarray, array, pdim);
 388       return;
 389     }
 390   /* Make dim zero based to avoid confusion.  */
 391   dim = (*pdim) - 1;
 392   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 393
 394   for (n = 0; n < dim; n++)
 395     {
 396       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 397
 398       if (extent[n] <= 0)
 399         extent[n] = 0;
 400     }
 401
 402   for (n = dim; n < rank; n++)
 403     {
 404       extent[n] =
 405         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 406
 407       if (extent[n] <= 0)
 408         extent[n] = 0;
 409     }
 410
 411   if (retarray->base_addr == NULL)
 412     {
 413       size_t alloc_size, str;
 414
 415       for (n = 0; n < rank; n++)
 416         {
 417           if (n == 0)
 418             str = 1;
 419           else
 420             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 421
 422           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 423
 424         }
 425
 426       retarray->offset = 0;
 427       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 428
 429       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 430
 431       if (alloc_size == 0)
 432         {
 433           /* Make sure we have a zero-sized array.  */
 434           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 435           return;
 436         }
 437       else
 438         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
 439     }
 440   else
 441     {
 442       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 443         runtime_error ("rank of return array incorrect in"
 444                        " PRODUCT intrinsic: is %ld, should be %ld",
 445                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 446                        (long int) rank);
 447
 448       if (unlikely (compile_options.bounds_check))
 449         {
 450           for (n=0; n < rank; n++)
 451             {
 452               index_type ret_extent;
 453
 454               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 455               if (extent[n] != ret_extent)
 456                 runtime_error ("Incorrect extent in return value of"
 457                                " PRODUCT intrinsic in dimension %ld:"
 458                                " is %ld, should be %ld", (long int) n + 1,
 459                                (long int) ret_extent, (long int) extent[n]);
 460             }
 461         }
 462     }
 463
 464   for (n = 0; n < rank; n++)
 465     {
 466       count[n] = 0;
 467       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 468     }
 469
 470   dest = retarray->base_addr;
 471
 472   while(1)
 473     {
 474       *dest = 1;
 475       count[0]++;
 476       dest += dstride[0];
 477       n = 0;
 478       while (count[n] == extent[n])
 479         {
 480           /* When we get to the end of a dimension, reset it and increment
 481              the next dimension.  */
 482           count[n] = 0;
 483           /* We could precalculate these products, but this is a less
 484              frequently used path so probably not worth it.  */
 485           dest -= dstride[n] * extent[n];
 486           n++;
 487           if (n >= rank)
 488             return;
 489           else
 490             {
 491               count[n]++;
 492               dest += dstride[n];
 493             }
 494         }
 495     }
 496 }
 497
 498 #endif