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