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