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 (libgfor).
   6
   7 Libgfortran is free software; you can redistribute it and/or
   8 modify it under the terms of the GNU Lesser General Public
   9 License as published by the Free Software Foundation; either
  10 version 2.1 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 Lesser General Public License for more details.
  16
  17 You should have received a copy of the GNU Lesser General Public
  18 License along with libgfor; see the file COPYING.LIB.  If not,
  19 write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  20 Boston, MA 02111-1307, USA.  */
  21
  22 #include "config.h"
  23 #include <stdlib.h>
  24 #include <assert.h>
  25 #include "libgfortran.h"
  26
  27 void
  28 __product_r4 (gfc_array_r4 * retarray, gfc_array_r4 *array, index_type *pdim)
  29 {
  30   index_type count[GFC_MAX_DIMENSIONS - 1];
  31   index_type extent[GFC_MAX_DIMENSIONS - 1];
  32   index_type sstride[GFC_MAX_DIMENSIONS - 1];
  33   index_type dstride[GFC_MAX_DIMENSIONS - 1];
  34   GFC_REAL_4 *base;
  35   GFC_REAL_4 *dest;
  36   index_type rank;
  37   index_type n;
  38   index_type len;
  39   index_type delta;
  40   index_type dim;
  41
  42   /* Make dim zero based to avoid confusion.  */
  43   dim = (*pdim) - 1;
  44   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  45   assert (rank == GFC_DESCRIPTOR_RANK (retarray));
  46   if (array->dim[0].stride == 0)
  47     array->dim[0].stride = 1;
  48   if (retarray->dim[0].stride == 0)
  49     retarray->dim[0].stride = 1;
  50
  51   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  52   delta = array->dim[dim].stride;
  53
  54   for (n = 0; n < dim; n++)
  55     {
  56       sstride[n] = array->dim[n].stride;
  57       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  58     }
  59   for (n = dim; n < rank; n++)
  60     {
  61       sstride[n] = array->dim[n + 1].stride;
  62       extent[n] =
  63         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  64     }
  65
  66   for (n = 0; n < rank; n++)
  67     {
  68       count[n] = 0;
  69       dstride[n] = retarray->dim[n].stride;
  70       if (extent[n] <= 0)
  71         len = 0;
  72     }
  73
  74   base = array->data;
  75   dest = retarray->data;
  76
  77   while (base)
  78     {
  79       GFC_REAL_4 *src;
  80       GFC_REAL_4 result;
  81       src = base;
  82       {
  83
  84   result = 1;
  85         if (len <= 0)
  86           *dest = 1;
  87         else
  88           {
  89             for (n = 0; n < len; n++, src += delta)
  90               {
  91
  92   result *= *src;
  93           }
  94             *dest = result;
  95           }
  96       }
  97       /* Advance to the next element.  */
  98       count[0]++;
  99       base += sstride[0];
 100       dest += dstride[0];
 101       n = 0;
 102       while (count[n] == extent[n])
 103         {
 104           /* When we get to the end of a dimension, reset it and increment
 105              the next dimension.  */
 106           count[n] = 0;
 107           /* We could precalculate these products, but this is a less
 108              frequently used path so proabably not worth it.  */
 109           base -= sstride[n] * extent[n];
 110           dest -= dstride[n] * extent[n];
 111           n++;
 112           if (n == rank)
 113             {
 114               /* Break out of the look.  */
 115               base = NULL;
 116               break;
 117             }
 118           else
 119             {
 120               count[n]++;
 121               base += sstride[n];
 122               dest += dstride[n];
 123             }
 124         }
 125     }
 126 }
 127
 128 void
 129 __mproduct_r4 (gfc_array_r4 * retarray, gfc_array_r4 * array, index_type *pdim, gfc_array_l4 * mask)
 130 {
 131   index_type count[GFC_MAX_DIMENSIONS - 1];
 132   index_type extent[GFC_MAX_DIMENSIONS - 1];
 133   index_type sstride[GFC_MAX_DIMENSIONS - 1];
 134   index_type dstride[GFC_MAX_DIMENSIONS - 1];
 135   index_type mstride[GFC_MAX_DIMENSIONS - 1];
 136   GFC_REAL_4 *dest;
 137   GFC_REAL_4 *base;
 138   GFC_LOGICAL_4 *mbase;
 139   int rank;
 140   int dim;
 141   index_type n;
 142   index_type len;
 143   index_type delta;
 144   index_type mdelta;
 145
 146   dim = (*pdim) - 1;
 147   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 148   assert (rank == GFC_DESCRIPTOR_RANK (retarray));
 149   if (array->dim[0].stride == 0)
 150     array->dim[0].stride = 1;
 151   if (retarray->dim[0].stride == 0)
 152     retarray->dim[0].stride = 1;
 153
 154   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 155   if (len <= 0)
 156     return;
 157   delta = array->dim[dim].stride;
 158   mdelta = mask->dim[dim].stride;
 159
 160   for (n = 0; n < dim; n++)
 161     {
 162       sstride[n] = array->dim[n].stride;
 163       mstride[n] = mask->dim[n].stride;
 164       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 165     }
 166   for (n = dim; n < rank; n++)
 167     {
 168       sstride[n] = array->dim[n + 1].stride;
 169       mstride[n] = mask->dim[n + 1].stride;
 170       extent[n] =
 171         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 172     }
 173
 174   for (n = 0; n < rank; n++)
 175     {
 176       count[n] = 0;
 177       dstride[n] = retarray->dim[n].stride;
 178       if (extent[n] <= 0)
 179         return;
 180     }
 181
 182   dest = retarray->data;
 183   base = array->data;
 184   mbase = mask->data;
 185
 186   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 187     {
 188       /* This allows the same loop to be used for all logical types.  */
 189       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 190       for (n = 0; n < rank; n++)
 191         mstride[n] <<= 1;
 192       mdelta <<= 1;
 193       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 194     }
 195
 196   while (base)
 197     {
 198       GFC_REAL_4 *src;
 199       GFC_LOGICAL_4 *msrc;
 200       GFC_REAL_4 result;
 201       src = base;
 202       msrc = mbase;
 203       {
 204
 205   result = 1;
 206         if (len <= 0)
 207           *dest = 1;
 208         else
 209           {
 210             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 211               {
 212
 213   if (*msrc)
 214     result *= *src;
 215               }
 216             *dest = result;
 217           }
 218       }
 219       /* Advance to the next element.  */
 220       count[0]++;
 221       base += sstride[0];
 222       mbase += mstride[0];
 223       dest += dstride[0];
 224       n = 0;
 225       while (count[n] == extent[n])
 226         {
 227           /* When we get to the end of a dimension, reset it and increment
 228              the next dimension.  */
 229           count[n] = 0;
 230           /* We could precalculate these products, but this is a less
 231              frequently used path so proabably not worth it.  */
 232           base -= sstride[n] * extent[n];
 233           mbase -= mstride[n] * extent[n];
 234           dest -= dstride[n] * extent[n];
 235           n++;
 236           if (n == rank)
 237             {
 238               /* Break out of the look.  */
 239               base = NULL;
 240               break;
 241             }
 242           else
 243             {
 244               count[n]++;
 245               base += sstride[n];
 246               mbase += mstride[n];
 247               dest += dstride[n];
 248             }
 249         }
 250     }
 251 }
 252