libgfortran/generated/maxval_r8.c

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