libgfortran/generated/product_r4.c

   1 /* Implementation of the PRODUCT intrinsic
   2    Copyright 2002 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 "config.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include "libgfortran.h"
  35
  36
  37 #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4)
  38
  39
  40 extern void product_r4 (gfc_array_r4 * const restrict,
  41         gfc_array_r4 * const restrict, const index_type * const restrict);
  42 export_proto(product_r4);
  43
  44 void
  45 product_r4 (gfc_array_r4 * const restrict retarray,
  46         gfc_array_r4 * const restrict array,
  47         const index_type * const restrict pdim)
  48 {
  49   index_type count[GFC_MAX_DIMENSIONS];
  50   index_type extent[GFC_MAX_DIMENSIONS];
  51   index_type sstride[GFC_MAX_DIMENSIONS];
  52   index_type dstride[GFC_MAX_DIMENSIONS];
  53   const GFC_REAL_4 * restrict base;
  54   GFC_REAL_4 * restrict dest;
  55   index_type rank;
  56   index_type n;
  57   index_type len;
  58   index_type delta;
  59   index_type dim;
  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   delta = array->dim[dim].stride;
  67
  68   for (n = 0; n < dim; n++)
  69     {
  70       sstride[n] = array->dim[n].stride;
  71       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  72
  73       if (extent[n] < 0)
  74         extent[n] = 0;
  75     }
  76   for (n = dim; n < rank; n++)
  77     {
  78       sstride[n] = array->dim[n + 1].stride;
  79       extent[n] =
  80         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  81
  82       if (extent[n] < 0)
  83         extent[n] = 0;
  84     }
  85
  86   if (retarray->data == NULL)
  87     {
  88       size_t alloc_size;
  89
  90       for (n = 0; n < rank; n++)
  91         {
  92           retarray->dim[n].lbound = 0;
  93           retarray->dim[n].ubound = extent[n]-1;
  94           if (n == 0)
  95             retarray->dim[n].stride = 1;
  96           else
  97             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
  98         }
  99
 100       retarray->offset = 0;
 101       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 102
 103       alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride
 104                    * extent[rank-1];
 105
 106       if (alloc_size == 0)
 107         {
 108           /* Make sure we have a zero-sized array.  */
 109           retarray->dim[0].lbound = 0;
 110           retarray->dim[0].ubound = -1;
 111           return;
 112         }
 113       else
 114         retarray->data = internal_malloc_size (alloc_size);
 115     }
 116   else
 117     {
 118       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 119         runtime_error ("rank of return array incorrect");
 120     }
 121
 122   for (n = 0; n < rank; n++)
 123     {
 124       count[n] = 0;
 125       dstride[n] = retarray->dim[n].stride;
 126       if (extent[n] <= 0)
 127         len = 0;
 128     }
 129
 130   base = array->data;
 131   dest = retarray->data;
 132
 133   while (base)
 134     {
 135       const GFC_REAL_4 * restrict src;
 136       GFC_REAL_4 result;
 137       src = base;
 138       {
 139
 140   result = 1;
 141         if (len <= 0)
 142           *dest = 1;
 143         else
 144           {
 145             for (n = 0; n < len; n++, src += delta)
 146               {
 147
 148   result *= *src;
 149           }
 150             *dest = result;
 151           }
 152       }
 153       /* Advance to the next element.  */
 154       count[0]++;
 155       base += sstride[0];
 156       dest += dstride[0];
 157       n = 0;
 158       while (count[n] == extent[n])
 159         {
 160           /* When we get to the end of a dimension, reset it and increment
 161              the next dimension.  */
 162           count[n] = 0;
 163           /* We could precalculate these products, but this is a less
 164              frequently used path so probably not worth it.  */
 165           base -= sstride[n] * extent[n];
 166           dest -= dstride[n] * extent[n];
 167           n++;
 168           if (n == rank)
 169             {
 170               /* Break out of the look.  */
 171               base = NULL;
 172               break;
 173             }
 174           else
 175             {
 176               count[n]++;
 177               base += sstride[n];
 178               dest += dstride[n];
 179             }
 180         }
 181     }
 182 }
 183
 184
 185 extern void mproduct_r4 (gfc_array_r4 * const restrict,
 186         gfc_array_r4 * const restrict, const index_type * const restrict,
 187         gfc_array_l4 * const restrict);
 188 export_proto(mproduct_r4);
 189
 190 void
 191 mproduct_r4 (gfc_array_r4 * const restrict retarray,
 192         gfc_array_r4 * const restrict array,
 193         const index_type * const restrict pdim,
 194         gfc_array_l4 * const restrict mask)
 195 {
 196   index_type count[GFC_MAX_DIMENSIONS];
 197   index_type extent[GFC_MAX_DIMENSIONS];
 198   index_type sstride[GFC_MAX_DIMENSIONS];
 199   index_type dstride[GFC_MAX_DIMENSIONS];
 200   index_type mstride[GFC_MAX_DIMENSIONS];
 201   GFC_REAL_4 * restrict dest;
 202   const GFC_REAL_4 * restrict base;
 203   const GFC_LOGICAL_4 * restrict mbase;
 204   int rank;
 205   int dim;
 206   index_type n;
 207   index_type len;
 208   index_type delta;
 209   index_type mdelta;
 210
 211   dim = (*pdim) - 1;
 212   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 213
 214   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 215   if (len <= 0)
 216     return;
 217   delta = array->dim[dim].stride;
 218   mdelta = mask->dim[dim].stride;
 219
 220   for (n = 0; n < dim; n++)
 221     {
 222       sstride[n] = array->dim[n].stride;
 223       mstride[n] = mask->dim[n].stride;
 224       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 225
 226       if (extent[n] < 0)
 227         extent[n] = 0;
 228
 229     }
 230   for (n = dim; n < rank; n++)
 231     {
 232       sstride[n] = array->dim[n + 1].stride;
 233       mstride[n] = mask->dim[n + 1].stride;
 234       extent[n] =
 235         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 236
 237       if (extent[n] < 0)
 238         extent[n] = 0;
 239     }
 240
 241   if (retarray->data == NULL)
 242     {
 243       size_t alloc_size;
 244
 245       for (n = 0; n < rank; n++)
 246         {
 247           retarray->dim[n].lbound = 0;
 248           retarray->dim[n].ubound = extent[n]-1;
 249           if (n == 0)
 250             retarray->dim[n].stride = 1;
 251           else
 252             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 253         }
 254
 255       alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride
 256                    * extent[rank-1];
 257
 258       retarray->offset = 0;
 259       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 260
 261       if (alloc_size == 0)
 262         {
 263           /* Make sure we have a zero-sized array.  */
 264           retarray->dim[0].lbound = 0;
 265           retarray->dim[0].ubound = -1;
 266           return;
 267         }
 268       else
 269         retarray->data = internal_malloc_size (alloc_size);
 270
 271     }
 272   else
 273     {
 274       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 275         runtime_error ("rank of return array incorrect");
 276     }
 277
 278   for (n = 0; n < rank; n++)
 279     {
 280       count[n] = 0;
 281       dstride[n] = retarray->dim[n].stride;
 282       if (extent[n] <= 0)
 283         return;
 284     }
 285
 286   dest = retarray->data;
 287   base = array->data;
 288   mbase = mask->data;
 289
 290   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 291     {
 292       /* This allows the same loop to be used for all logical types.  */
 293       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 294       for (n = 0; n < rank; n++)
 295         mstride[n] <<= 1;
 296       mdelta <<= 1;
 297       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 298     }
 299
 300   while (base)
 301     {
 302       const GFC_REAL_4 * restrict src;
 303       const GFC_LOGICAL_4 * restrict msrc;
 304       GFC_REAL_4 result;
 305       src = base;
 306       msrc = mbase;
 307       {
 308
 309   result = 1;
 310         if (len <= 0)
 311           *dest = 1;
 312         else
 313           {
 314             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 315               {
 316
 317   if (*msrc)
 318     result *= *src;
 319               }
 320             *dest = result;
 321           }
 322       }
 323       /* Advance to the next element.  */
 324       count[0]++;
 325       base += sstride[0];
 326       mbase += mstride[0];
 327       dest += dstride[0];
 328       n = 0;
 329       while (count[n] == extent[n])
 330         {
 331           /* When we get to the end of a dimension, reset it and increment
 332              the next dimension.  */
 333           count[n] = 0;
 334           /* We could precalculate these products, but this is a less
 335              frequently used path so probably not worth it.  */
 336           base -= sstride[n] * extent[n];
 337           mbase -= mstride[n] * extent[n];
 338           dest -= dstride[n] * extent[n];
 339           n++;
 340           if (n == rank)
 341             {
 342               /* Break out of the look.  */
 343               base = NULL;
 344               break;
 345             }
 346           else
 347             {
 348               count[n]++;
 349               base += sstride[n];
 350               mbase += mstride[n];
 351               dest += dstride[n];
 352             }
 353         }
 354     }
 355 }
 356
 357
 358 extern void sproduct_r4 (gfc_array_r4 * const restrict,
 359         gfc_array_r4 * const restrict, const index_type * const restrict,
 360         GFC_LOGICAL_4 *);
 361 export_proto(sproduct_r4);
 362
 363 void
 364 sproduct_r4 (gfc_array_r4 * const restrict retarray,
 365         gfc_array_r4 * const restrict array,
 366         const index_type * const restrict pdim,
 367         GFC_LOGICAL_4 * mask)
 368 {
 369   index_type rank;
 370   index_type n;
 371   index_type dstride;
 372   GFC_REAL_4 *dest;
 373
 374   if (*mask)
 375     {
 376       product_r4 (retarray, array, pdim);
 377       return;
 378     }
 379     rank = GFC_DESCRIPTOR_RANK (array);
 380   if (rank <= 0)
 381     runtime_error ("Rank of array needs to be > 0");
 382
 383   if (retarray->data == NULL)
 384     {
 385       retarray->dim[0].lbound = 0;
 386       retarray->dim[0].ubound = rank-1;
 387       retarray->dim[0].stride = 1;
 388       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 389       retarray->offset = 0;
 390       retarray->data = internal_malloc_size (sizeof (GFC_REAL_4) * rank);
 391     }
 392   else
 393     {
 394       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 395         runtime_error ("rank of return array does not equal 1");
 396
 397       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 398         runtime_error ("dimension of return array incorrect");
 399     }
 400
 401     dstride = retarray->dim[0].stride;
 402     dest = retarray->data;
 403
 404     for (n = 0; n < rank; n++)
 405       dest[n * dstride] = 1 ;
 406 }
 407
 408 #endif