libgfortran/generated/product_c4.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_COMPLEX_4) && defined (HAVE_GFC_COMPLEX_4)
  38
  39
  40 extern void product_c4 (gfc_array_c4 * const restrict,
  41         gfc_array_c4 * const restrict, const index_type * const restrict);
  42 export_proto(product_c4);
  43
  44 void
  45 product_c4 (gfc_array_c4 * const restrict retarray,
  46         gfc_array_c4 * 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_COMPLEX_4 * restrict base;
  54   GFC_COMPLEX_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_COMPLEX_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_COMPLEX_4 * restrict src;
 136       GFC_COMPLEX_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_c4 (gfc_array_c4 * const restrict,
 186         gfc_array_c4 * const restrict, const index_type * const restrict,
 187         gfc_array_l1 * const restrict);
 188 export_proto(mproduct_c4);
 189
 190 void
 191 mproduct_c4 (gfc_array_c4 * const restrict retarray,
 192         gfc_array_c4 * const restrict array,
 193         const index_type * const restrict pdim,
 194         gfc_array_l1 * 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_COMPLEX_4 * restrict dest;
 202   const GFC_COMPLEX_4 * restrict base;
 203   const GFC_LOGICAL_1 * 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   int mask_kind;
 211
 212   dim = (*pdim) - 1;
 213   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 214
 215   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 216   if (len <= 0)
 217     return;
 218
 219   mbase = mask->data;
 220
 221   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 222
 223   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 224 #ifdef HAVE_GFC_LOGICAL_16
 225       || mask_kind == 16
 226 #endif
 227       )
 228     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 229   else
 230     runtime_error ("Funny sized logical array");
 231
 232   delta = array->dim[dim].stride;
 233   mdelta = mask->dim[dim].stride * mask_kind;
 234
 235   for (n = 0; n < dim; n++)
 236     {
 237       sstride[n] = array->dim[n].stride;
 238       mstride[n] = mask->dim[n].stride * mask_kind;
 239       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 240
 241       if (extent[n] < 0)
 242         extent[n] = 0;
 243
 244     }
 245   for (n = dim; n < rank; n++)
 246     {
 247       sstride[n] = array->dim[n + 1].stride;
 248       mstride[n] = mask->dim[n + 1].stride * mask_kind;
 249       extent[n] =
 250         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 251
 252       if (extent[n] < 0)
 253         extent[n] = 0;
 254     }
 255
 256   if (retarray->data == NULL)
 257     {
 258       size_t alloc_size;
 259
 260       for (n = 0; n < rank; n++)
 261         {
 262           retarray->dim[n].lbound = 0;
 263           retarray->dim[n].ubound = extent[n]-1;
 264           if (n == 0)
 265             retarray->dim[n].stride = 1;
 266           else
 267             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 268         }
 269
 270       alloc_size = sizeof (GFC_COMPLEX_4) * retarray->dim[rank-1].stride
 271                    * extent[rank-1];
 272
 273       retarray->offset = 0;
 274       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 275
 276       if (alloc_size == 0)
 277         {
 278           /* Make sure we have a zero-sized array.  */
 279           retarray->dim[0].lbound = 0;
 280           retarray->dim[0].ubound = -1;
 281           return;
 282         }
 283       else
 284         retarray->data = internal_malloc_size (alloc_size);
 285
 286     }
 287   else
 288     {
 289       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 290         runtime_error ("rank of return array incorrect");
 291     }
 292
 293   for (n = 0; n < rank; n++)
 294     {
 295       count[n] = 0;
 296       dstride[n] = retarray->dim[n].stride;
 297       if (extent[n] <= 0)
 298         return;
 299     }
 300
 301   dest = retarray->data;
 302   base = array->data;
 303
 304   while (base)
 305     {
 306       const GFC_COMPLEX_4 * restrict src;
 307       const GFC_LOGICAL_1 * restrict msrc;
 308       GFC_COMPLEX_4 result;
 309       src = base;
 310       msrc = mbase;
 311       {
 312
 313   result = 1;
 314         if (len <= 0)
 315           *dest = 1;
 316         else
 317           {
 318             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 319               {
 320
 321   if (*msrc)
 322     result *= *src;
 323               }
 324             *dest = result;
 325           }
 326       }
 327       /* Advance to the next element.  */
 328       count[0]++;
 329       base += sstride[0];
 330       mbase += mstride[0];
 331       dest += dstride[0];
 332       n = 0;
 333       while (count[n] == extent[n])
 334         {
 335           /* When we get to the end of a dimension, reset it and increment
 336              the next dimension.  */
 337           count[n] = 0;
 338           /* We could precalculate these products, but this is a less
 339              frequently used path so probably not worth it.  */
 340           base -= sstride[n] * extent[n];
 341           mbase -= mstride[n] * extent[n];
 342           dest -= dstride[n] * extent[n];
 343           n++;
 344           if (n == rank)
 345             {
 346               /* Break out of the look.  */
 347               base = NULL;
 348               break;
 349             }
 350           else
 351             {
 352               count[n]++;
 353               base += sstride[n];
 354               mbase += mstride[n];
 355               dest += dstride[n];
 356             }
 357         }
 358     }
 359 }
 360
 361
 362 extern void sproduct_c4 (gfc_array_c4 * const restrict,
 363         gfc_array_c4 * const restrict, const index_type * const restrict,
 364         GFC_LOGICAL_4 *);
 365 export_proto(sproduct_c4);
 366
 367 void
 368 sproduct_c4 (gfc_array_c4 * const restrict retarray,
 369         gfc_array_c4 * const restrict array,
 370         const index_type * const restrict pdim,
 371         GFC_LOGICAL_4 * mask)
 372 {
 373   index_type rank;
 374   index_type n;
 375   index_type dstride;
 376   GFC_COMPLEX_4 *dest;
 377
 378   if (*mask)
 379     {
 380       product_c4 (retarray, array, pdim);
 381       return;
 382     }
 383     rank = GFC_DESCRIPTOR_RANK (array);
 384   if (rank <= 0)
 385     runtime_error ("Rank of array needs to be > 0");
 386
 387   if (retarray->data == NULL)
 388     {
 389       retarray->dim[0].lbound = 0;
 390       retarray->dim[0].ubound = rank-1;
 391       retarray->dim[0].stride = 1;
 392       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 393       retarray->offset = 0;
 394       retarray->data = internal_malloc_size (sizeof (GFC_COMPLEX_4) * rank);
 395     }
 396   else
 397     {
 398       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 399         runtime_error ("rank of return array does not equal 1");
 400
 401       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 402         runtime_error ("dimension of return array incorrect");
 403     }
 404
 405     dstride = retarray->dim[0].stride;
 406     dest = retarray->data;
 407
 408     for (n = 0; n < rank; n++)
 409       dest[n * dstride] = 1 ;
 410 }
 411
 412 #endif