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., 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_REAL_4) && defined (HAVE_GFC_REAL_4)
  39
  40
  41 extern void maxval_r4 (gfc_array_r4 * const restrict,
  42         gfc_array_r4 * const restrict, const index_type * const restrict);
  43 export_proto(maxval_r4);
  44
  45 void
  46 maxval_r4 (gfc_array_r4 * const restrict retarray,
  47         gfc_array_r4 * const restrict array,
  48         const index_type * const restrict pdim)
  49 {
  50   index_type count[GFC_MAX_DIMENSIONS];
  51   index_type extent[GFC_MAX_DIMENSIONS];
  52   index_type sstride[GFC_MAX_DIMENSIONS];
  53   index_type dstride[GFC_MAX_DIMENSIONS];
  54   const GFC_REAL_4 * restrict base;
  55   GFC_REAL_4 * restrict dest;
  56   index_type rank;
  57   index_type n;
  58   index_type len;
  59   index_type delta;
  60   index_type dim;
  61
  62   /* Make dim zero based to avoid confusion.  */
  63   dim = (*pdim) - 1;
  64   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  65
  66   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  67   delta = array->dim[dim].stride;
  68
  69   for (n = 0; n < dim; n++)
  70     {
  71       sstride[n] = array->dim[n].stride;
  72       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  73
  74       if (extent[n] < 0)
  75         extent[n] = 0;
  76     }
  77   for (n = dim; n < rank; n++)
  78     {
  79       sstride[n] = array->dim[n + 1].stride;
  80       extent[n] =
  81         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  82
  83       if (extent[n] < 0)
  84         extent[n] = 0;
  85     }
  86
  87   if (retarray->data == NULL)
  88     {
  89       size_t alloc_size;
  90
  91       for (n = 0; n < rank; n++)
  92         {
  93           retarray->dim[n].lbound = 0;
  94           retarray->dim[n].ubound = extent[n]-1;
  95           if (n == 0)
  96             retarray->dim[n].stride = 1;
  97           else
  98             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
  99         }
 100
 101       retarray->offset = 0;
 102       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 103
 104       alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride
 105                    * extent[rank-1];
 106
 107       if (alloc_size == 0)
 108         {
 109           /* Make sure we have a zero-sized array.  */
 110           retarray->dim[0].lbound = 0;
 111           retarray->dim[0].ubound = -1;
 112           return;
 113         }
 114       else
 115         retarray->data = internal_malloc_size (alloc_size);
 116     }
 117   else
 118     {
 119       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 120         runtime_error ("rank of return array incorrect");
 121     }
 122
 123   for (n = 0; n < rank; n++)
 124     {
 125       count[n] = 0;
 126       dstride[n] = retarray->dim[n].stride;
 127       if (extent[n] <= 0)
 128         len = 0;
 129     }
 130
 131   base = array->data;
 132   dest = retarray->data;
 133
 134   while (base)
 135     {
 136       const GFC_REAL_4 * restrict src;
 137       GFC_REAL_4 result;
 138       src = base;
 139       {
 140
 141   result = -GFC_REAL_4_HUGE;
 142         if (len <= 0)
 143           *dest = -GFC_REAL_4_HUGE;
 144         else
 145           {
 146             for (n = 0; n < len; n++, src += delta)
 147               {
 148
 149   if (*src > result)
 150     result = *src;
 151           }
 152             *dest = result;
 153           }
 154       }
 155       /* Advance to the next element.  */
 156       count[0]++;
 157       base += sstride[0];
 158       dest += dstride[0];
 159       n = 0;
 160       while (count[n] == extent[n])
 161         {
 162           /* When we get to the end of a dimension, reset it and increment
 163              the next dimension.  */
 164           count[n] = 0;
 165           /* We could precalculate these products, but this is a less
 166              frequently used path so probably not worth it.  */
 167           base -= sstride[n] * extent[n];
 168           dest -= dstride[n] * extent[n];
 169           n++;
 170           if (n == rank)
 171             {
 172               /* Break out of the look.  */
 173               base = NULL;
 174               break;
 175             }
 176           else
 177             {
 178               count[n]++;
 179               base += sstride[n];
 180               dest += dstride[n];
 181             }
 182         }
 183     }
 184 }
 185
 186
 187 extern void mmaxval_r4 (gfc_array_r4 * const restrict,
 188         gfc_array_r4 * const restrict, const index_type * const restrict,
 189         gfc_array_l4 * const restrict);
 190 export_proto(mmaxval_r4);
 191
 192 void
 193 mmaxval_r4 (gfc_array_r4 * const restrict retarray,
 194         gfc_array_r4 * const restrict array,
 195         const index_type * const restrict pdim,
 196         gfc_array_l4 * const restrict mask)
 197 {
 198   index_type count[GFC_MAX_DIMENSIONS];
 199   index_type extent[GFC_MAX_DIMENSIONS];
 200   index_type sstride[GFC_MAX_DIMENSIONS];
 201   index_type dstride[GFC_MAX_DIMENSIONS];
 202   index_type mstride[GFC_MAX_DIMENSIONS];
 203   GFC_REAL_4 * restrict dest;
 204   const GFC_REAL_4 * restrict base;
 205   const GFC_LOGICAL_4 * restrict mbase;
 206   int rank;
 207   int dim;
 208   index_type n;
 209   index_type len;
 210   index_type delta;
 211   index_type mdelta;
 212
 213   dim = (*pdim) - 1;
 214   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 215
 216   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 217   if (len <= 0)
 218     return;
 219   delta = array->dim[dim].stride;
 220   mdelta = mask->dim[dim].stride;
 221
 222   for (n = 0; n < dim; n++)
 223     {
 224       sstride[n] = array->dim[n].stride;
 225       mstride[n] = mask->dim[n].stride;
 226       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 227
 228       if (extent[n] < 0)
 229         extent[n] = 0;
 230
 231     }
 232   for (n = dim; n < rank; n++)
 233     {
 234       sstride[n] = array->dim[n + 1].stride;
 235       mstride[n] = mask->dim[n + 1].stride;
 236       extent[n] =
 237         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 238
 239       if (extent[n] < 0)
 240         extent[n] = 0;
 241     }
 242
 243   if (retarray->data == NULL)
 244     {
 245       size_t alloc_size;
 246
 247       for (n = 0; n < rank; n++)
 248         {
 249           retarray->dim[n].lbound = 0;
 250           retarray->dim[n].ubound = extent[n]-1;
 251           if (n == 0)
 252             retarray->dim[n].stride = 1;
 253           else
 254             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 255         }
 256
 257       alloc_size = sizeof (GFC_REAL_4) * retarray->dim[rank-1].stride
 258                    * extent[rank-1];
 259
 260       retarray->offset = 0;
 261       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 262
 263       if (alloc_size == 0)
 264         {
 265           /* Make sure we have a zero-sized array.  */
 266           retarray->dim[0].lbound = 0;
 267           retarray->dim[0].ubound = -1;
 268           return;
 269         }
 270       else
 271         retarray->data = internal_malloc_size (alloc_size);
 272
 273     }
 274   else
 275     {
 276       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 277         runtime_error ("rank of return array incorrect");
 278     }
 279
 280   for (n = 0; n < rank; n++)
 281     {
 282       count[n] = 0;
 283       dstride[n] = retarray->dim[n].stride;
 284       if (extent[n] <= 0)
 285         return;
 286     }
 287
 288   dest = retarray->data;
 289   base = array->data;
 290   mbase = mask->data;
 291
 292   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 293     {
 294       /* This allows the same loop to be used for all logical types.  */
 295       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 296       for (n = 0; n < rank; n++)
 297         mstride[n] <<= 1;
 298       mdelta <<= 1;
 299       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 300     }
 301
 302   while (base)
 303     {
 304       const GFC_REAL_4 * restrict src;
 305       const GFC_LOGICAL_4 * restrict msrc;
 306       GFC_REAL_4 result;
 307       src = base;
 308       msrc = mbase;
 309       {
 310
 311   result = -GFC_REAL_4_HUGE;
 312         if (len <= 0)
 313           *dest = -GFC_REAL_4_HUGE;
 314         else
 315           {
 316             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 317               {
 318
 319   if (*msrc && *src > result)
 320     result = *src;
 321               }
 322             *dest = result;
 323           }
 324       }
 325       /* Advance to the next element.  */
 326       count[0]++;
 327       base += sstride[0];
 328       mbase += mstride[0];
 329       dest += dstride[0];
 330       n = 0;
 331       while (count[n] == extent[n])
 332         {
 333           /* When we get to the end of a dimension, reset it and increment
 334              the next dimension.  */
 335           count[n] = 0;
 336           /* We could precalculate these products, but this is a less
 337              frequently used path so probably not worth it.  */
 338           base -= sstride[n] * extent[n];
 339           mbase -= mstride[n] * extent[n];
 340           dest -= dstride[n] * extent[n];
 341           n++;
 342           if (n == rank)
 343             {
 344               /* Break out of the look.  */
 345               base = NULL;
 346               break;
 347             }
 348           else
 349             {
 350               count[n]++;
 351               base += sstride[n];
 352               mbase += mstride[n];
 353               dest += dstride[n];
 354             }
 355         }
 356     }
 357 }
 358
 359
 360 extern void smaxval_r4 (gfc_array_r4 * const restrict,
 361         gfc_array_r4 * const restrict, const index_type * const restrict,
 362         GFC_LOGICAL_4 *);
 363 export_proto(smaxval_r4);
 364
 365 void
 366 smaxval_r4 (gfc_array_r4 * const restrict retarray,
 367         gfc_array_r4 * const restrict array,
 368         const index_type * const restrict pdim,
 369         GFC_LOGICAL_4 * mask)
 370 {
 371   index_type rank;
 372   index_type n;
 373   index_type dstride;
 374   GFC_REAL_4 *dest;
 375
 376   if (*mask)
 377     {
 378       maxval_r4 (retarray, array, pdim);
 379       return;
 380     }
 381     rank = GFC_DESCRIPTOR_RANK (array);
 382   if (rank <= 0)
 383     runtime_error ("Rank of array needs to be > 0");
 384
 385   if (retarray->data == NULL)
 386     {
 387       retarray->dim[0].lbound = 0;
 388       retarray->dim[0].ubound = rank-1;
 389       retarray->dim[0].stride = 1;
 390       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 391       retarray->offset = 0;
 392       retarray->data = internal_malloc_size (sizeof (GFC_REAL_4) * rank);
 393     }
 394   else
 395     {
 396       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 397         runtime_error ("rank of return array does not equal 1");
 398
 399       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 400         runtime_error ("dimension of return array incorrect");
 401     }
 402
 403     dstride = retarray->dim[0].stride;
 404     dest = retarray->data;
 405
 406     for (n = 0; n < rank; n++)
 407       dest[n * dstride] = -GFC_REAL_4_HUGE ;
 408 }
 409
 410 #endif