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