libgfortran/generated/product_c8.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., 59 Temple Place - Suite 330,
  29 Boston, MA 02111-1307, USA.  */
  30
  31 #include "config.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include "libgfortran.h"
  35
  36
  37 extern void product_c8 (gfc_array_c8 *, gfc_array_c8 *, index_type *);
  38 export_proto(product_c8);
  39
  40 void
  41 product_c8 (gfc_array_c8 *retarray, gfc_array_c8 *array, index_type *pdim)
  42 {
  43   index_type count[GFC_MAX_DIMENSIONS - 1];
  44   index_type extent[GFC_MAX_DIMENSIONS - 1];
  45   index_type sstride[GFC_MAX_DIMENSIONS - 1];
  46   index_type dstride[GFC_MAX_DIMENSIONS - 1];
  47   GFC_COMPLEX_8 *base;
  48   GFC_COMPLEX_8 *dest;
  49   index_type rank;
  50   index_type n;
  51   index_type len;
  52   index_type delta;
  53   index_type dim;
  54
  55   /* Make dim zero based to avoid confusion.  */
  56   dim = (*pdim) - 1;
  57   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  58   if (array->dim[0].stride == 0)
  59     array->dim[0].stride = 1;
  60
  61   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  62   delta = array->dim[dim].stride;
  63
  64   for (n = 0; n < dim; n++)
  65     {
  66       sstride[n] = array->dim[n].stride;
  67       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  68     }
  69   for (n = dim; n < rank; n++)
  70     {
  71       sstride[n] = array->dim[n + 1].stride;
  72       extent[n] =
  73         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  74     }
  75
  76   if (retarray->data == NULL)
  77     {
  78       for (n = 0; n < rank; n++)
  79         {
  80           retarray->dim[n].lbound = 0;
  81           retarray->dim[n].ubound = extent[n]-1;
  82           if (n == 0)
  83             retarray->dim[n].stride = 1;
  84           else
  85             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
  86         }
  87
  88       retarray->data
  89          = internal_malloc_size (sizeof (GFC_COMPLEX_8)
  90                                  * retarray->dim[rank-1].stride
  91                                  * extent[rank-1]);
  92       retarray->base = 0;
  93       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
  94     }
  95   else
  96     {
  97       if (retarray->dim[0].stride == 0)
  98         retarray->dim[0].stride = 1;
  99
 100       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 101         runtime_error ("rank of return array incorrect");
 102     }
 103
 104   for (n = 0; n < rank; n++)
 105     {
 106       count[n] = 0;
 107       dstride[n] = retarray->dim[n].stride;
 108       if (extent[n] <= 0)
 109         len = 0;
 110     }
 111
 112   base = array->data;
 113   dest = retarray->data;
 114
 115   while (base)
 116     {
 117       GFC_COMPLEX_8 *src;
 118       GFC_COMPLEX_8 result;
 119       src = base;
 120       {
 121
 122   result = 1;
 123         if (len <= 0)
 124           *dest = 1;
 125         else
 126           {
 127             for (n = 0; n < len; n++, src += delta)
 128               {
 129
 130   result *= *src;
 131           }
 132             *dest = result;
 133           }
 134       }
 135       /* Advance to the next element.  */
 136       count[0]++;
 137       base += sstride[0];
 138       dest += dstride[0];
 139       n = 0;
 140       while (count[n] == extent[n])
 141         {
 142           /* When we get to the end of a dimension, reset it and increment
 143              the next dimension.  */
 144           count[n] = 0;
 145           /* We could precalculate these products, but this is a less
 146              frequently used path so proabably not worth it.  */
 147           base -= sstride[n] * extent[n];
 148           dest -= dstride[n] * extent[n];
 149           n++;
 150           if (n == rank)
 151             {
 152               /* Break out of the look.  */
 153               base = NULL;
 154               break;
 155             }
 156           else
 157             {
 158               count[n]++;
 159               base += sstride[n];
 160               dest += dstride[n];
 161             }
 162         }
 163     }
 164 }
 165
 166
 167 extern void mproduct_c8 (gfc_array_c8 *, gfc_array_c8 *, index_type *,
 168                                                gfc_array_l4 *);
 169 export_proto(mproduct_c8);
 170
 171 void
 172 mproduct_c8 (gfc_array_c8 * retarray, gfc_array_c8 * array,
 173                                   index_type *pdim, gfc_array_l4 * mask)
 174 {
 175   index_type count[GFC_MAX_DIMENSIONS - 1];
 176   index_type extent[GFC_MAX_DIMENSIONS - 1];
 177   index_type sstride[GFC_MAX_DIMENSIONS - 1];
 178   index_type dstride[GFC_MAX_DIMENSIONS - 1];
 179   index_type mstride[GFC_MAX_DIMENSIONS - 1];
 180   GFC_COMPLEX_8 *dest;
 181   GFC_COMPLEX_8 *base;
 182   GFC_LOGICAL_4 *mbase;
 183   int rank;
 184   int dim;
 185   index_type n;
 186   index_type len;
 187   index_type delta;
 188   index_type mdelta;
 189
 190   dim = (*pdim) - 1;
 191   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 192   if (array->dim[0].stride == 0)
 193     array->dim[0].stride = 1;
 194
 195   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 196   if (len <= 0)
 197     return;
 198   delta = array->dim[dim].stride;
 199   mdelta = mask->dim[dim].stride;
 200
 201   for (n = 0; n < dim; n++)
 202     {
 203       sstride[n] = array->dim[n].stride;
 204       mstride[n] = mask->dim[n].stride;
 205       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 206     }
 207   for (n = dim; n < rank; n++)
 208     {
 209       sstride[n] = array->dim[n + 1].stride;
 210       mstride[n] = mask->dim[n + 1].stride;
 211       extent[n] =
 212         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 213     }
 214
 215   if (retarray->data == NULL)
 216     {
 217       for (n = 0; n < rank; n++)
 218         {
 219           retarray->dim[n].lbound = 0;
 220           retarray->dim[n].ubound = extent[n]-1;
 221           if (n == 0)
 222             retarray->dim[n].stride = 1;
 223           else
 224             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 225         }
 226
 227       retarray->data
 228          = internal_malloc_size (sizeof (GFC_COMPLEX_8)
 229                                  * retarray->dim[rank-1].stride
 230                                  * extent[rank-1]);
 231       retarray->base = 0;
 232       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 233     }
 234   else
 235     {
 236       if (retarray->dim[0].stride == 0)
 237         retarray->dim[0].stride = 1;
 238
 239       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 240         runtime_error ("rank of return array incorrect");
 241     }
 242
 243   for (n = 0; n < rank; n++)
 244     {
 245       count[n] = 0;
 246       dstride[n] = retarray->dim[n].stride;
 247       if (extent[n] <= 0)
 248         return;
 249     }
 250
 251   dest = retarray->data;
 252   base = array->data;
 253   mbase = mask->data;
 254
 255   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 256     {
 257       /* This allows the same loop to be used for all logical types.  */
 258       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 259       for (n = 0; n < rank; n++)
 260         mstride[n] <<= 1;
 261       mdelta <<= 1;
 262       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 263     }
 264
 265   while (base)
 266     {
 267       GFC_COMPLEX_8 *src;
 268       GFC_LOGICAL_4 *msrc;
 269       GFC_COMPLEX_8 result;
 270       src = base;
 271       msrc = mbase;
 272       {
 273
 274   result = 1;
 275         if (len <= 0)
 276           *dest = 1;
 277         else
 278           {
 279             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 280               {
 281
 282   if (*msrc)
 283     result *= *src;
 284               }
 285             *dest = result;
 286           }
 287       }
 288       /* Advance to the next element.  */
 289       count[0]++;
 290       base += sstride[0];
 291       mbase += mstride[0];
 292       dest += dstride[0];
 293       n = 0;
 294       while (count[n] == extent[n])
 295         {
 296           /* When we get to the end of a dimension, reset it and increment
 297              the next dimension.  */
 298           count[n] = 0;
 299           /* We could precalculate these products, but this is a less
 300              frequently used path so proabably not worth it.  */
 301           base -= sstride[n] * extent[n];
 302           mbase -= mstride[n] * extent[n];
 303           dest -= dstride[n] * extent[n];
 304           n++;
 305           if (n == rank)
 306             {
 307               /* Break out of the look.  */
 308               base = NULL;
 309               break;
 310             }
 311           else
 312             {
 313               count[n]++;
 314               base += sstride[n];
 315               mbase += mstride[n];
 316               dest += dstride[n];
 317             }
 318         }
 319     }
 320 }
 321