libgfortran/generated/maxloc1_8_r10.c

   1 /* Implementation of the MAXLOC 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 <limits.h>
  35 #include "libgfortran.h"
  36
  37
  38 #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8)
  39
  40
  41 extern void maxloc1_8_r10 (gfc_array_i8 * const restrict,
  42         gfc_array_r10 * const restrict, const index_type * const restrict);
  43 export_proto(maxloc1_8_r10);
  44
  45 void
  46 maxloc1_8_r10 (gfc_array_i8 * const restrict retarray,
  47         gfc_array_r10 * 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_10 * restrict base;
  55   GFC_INTEGER_8 * 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_INTEGER_8) * 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_10 * restrict src;
 137       GFC_INTEGER_8 result;
 138       src = base;
 139       {
 140
 141   GFC_REAL_10 maxval;
 142   maxval = -GFC_REAL_10_HUGE;
 143   result = 0;
 144         if (len <= 0)
 145           *dest = 0;
 146         else
 147           {
 148             for (n = 0; n < len; n++, src += delta)
 149               {
 150
 151   if (*src > maxval || !result)
 152     {
 153       maxval = *src;
 154       result = (GFC_INTEGER_8)n + 1;
 155     }
 156           }
 157             *dest = result;
 158           }
 159       }
 160       /* Advance to the next element.  */
 161       count[0]++;
 162       base += sstride[0];
 163       dest += dstride[0];
 164       n = 0;
 165       while (count[n] == extent[n])
 166         {
 167           /* When we get to the end of a dimension, reset it and increment
 168              the next dimension.  */
 169           count[n] = 0;
 170           /* We could precalculate these products, but this is a less
 171              frequently used path so probably not worth it.  */
 172           base -= sstride[n] * extent[n];
 173           dest -= dstride[n] * extent[n];
 174           n++;
 175           if (n == rank)
 176             {
 177               /* Break out of the look.  */
 178               base = NULL;
 179               break;
 180             }
 181           else
 182             {
 183               count[n]++;
 184               base += sstride[n];
 185               dest += dstride[n];
 186             }
 187         }
 188     }
 189 }
 190
 191
 192 extern void mmaxloc1_8_r10 (gfc_array_i8 * const restrict,
 193         gfc_array_r10 * const restrict, const index_type * const restrict,
 194         gfc_array_l1 * const restrict);
 195 export_proto(mmaxloc1_8_r10);
 196
 197 void
 198 mmaxloc1_8_r10 (gfc_array_i8 * const restrict retarray,
 199         gfc_array_r10 * const restrict array,
 200         const index_type * const restrict pdim,
 201         gfc_array_l1 * const restrict mask)
 202 {
 203   index_type count[GFC_MAX_DIMENSIONS];
 204   index_type extent[GFC_MAX_DIMENSIONS];
 205   index_type sstride[GFC_MAX_DIMENSIONS];
 206   index_type dstride[GFC_MAX_DIMENSIONS];
 207   index_type mstride[GFC_MAX_DIMENSIONS];
 208   GFC_INTEGER_8 * restrict dest;
 209   const GFC_REAL_10 * restrict base;
 210   const GFC_LOGICAL_1 * restrict mbase;
 211   int rank;
 212   int dim;
 213   index_type n;
 214   index_type len;
 215   index_type delta;
 216   index_type mdelta;
 217   int mask_kind;
 218
 219   dim = (*pdim) - 1;
 220   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 221
 222   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 223   if (len <= 0)
 224     return;
 225
 226   mbase = mask->data;
 227
 228   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 229
 230   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 231 #ifdef HAVE_GFC_LOGICAL_16
 232       || mask_kind == 16
 233 #endif
 234       )
 235     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 236   else
 237     runtime_error ("Funny sized logical array");
 238
 239   delta = array->dim[dim].stride;
 240   mdelta = mask->dim[dim].stride * mask_kind;
 241
 242   for (n = 0; n < dim; n++)
 243     {
 244       sstride[n] = array->dim[n].stride;
 245       mstride[n] = mask->dim[n].stride * mask_kind;
 246       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 247
 248       if (extent[n] < 0)
 249         extent[n] = 0;
 250
 251     }
 252   for (n = dim; n < rank; n++)
 253     {
 254       sstride[n] = array->dim[n + 1].stride;
 255       mstride[n] = mask->dim[n + 1].stride * mask_kind;
 256       extent[n] =
 257         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 258
 259       if (extent[n] < 0)
 260         extent[n] = 0;
 261     }
 262
 263   if (retarray->data == NULL)
 264     {
 265       size_t alloc_size;
 266
 267       for (n = 0; n < rank; n++)
 268         {
 269           retarray->dim[n].lbound = 0;
 270           retarray->dim[n].ubound = extent[n]-1;
 271           if (n == 0)
 272             retarray->dim[n].stride = 1;
 273           else
 274             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 275         }
 276
 277       alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
 278                    * extent[rank-1];
 279
 280       retarray->offset = 0;
 281       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 282
 283       if (alloc_size == 0)
 284         {
 285           /* Make sure we have a zero-sized array.  */
 286           retarray->dim[0].lbound = 0;
 287           retarray->dim[0].ubound = -1;
 288           return;
 289         }
 290       else
 291         retarray->data = internal_malloc_size (alloc_size);
 292
 293     }
 294   else
 295     {
 296       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 297         runtime_error ("rank of return array incorrect");
 298     }
 299
 300   for (n = 0; n < rank; n++)
 301     {
 302       count[n] = 0;
 303       dstride[n] = retarray->dim[n].stride;
 304       if (extent[n] <= 0)
 305         return;
 306     }
 307
 308   dest = retarray->data;
 309   base = array->data;
 310
 311   while (base)
 312     {
 313       const GFC_REAL_10 * restrict src;
 314       const GFC_LOGICAL_1 * restrict msrc;
 315       GFC_INTEGER_8 result;
 316       src = base;
 317       msrc = mbase;
 318       {
 319
 320   GFC_REAL_10 maxval;
 321   maxval = -GFC_REAL_10_HUGE;
 322   result = 0;
 323         if (len <= 0)
 324           *dest = 0;
 325         else
 326           {
 327             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 328               {
 329
 330   if (*msrc && (*src > maxval || !result))
 331     {
 332       maxval = *src;
 333       result = (GFC_INTEGER_8)n + 1;
 334     }
 335               }
 336             *dest = result;
 337           }
 338       }
 339       /* Advance to the next element.  */
 340       count[0]++;
 341       base += sstride[0];
 342       mbase += mstride[0];
 343       dest += dstride[0];
 344       n = 0;
 345       while (count[n] == extent[n])
 346         {
 347           /* When we get to the end of a dimension, reset it and increment
 348              the next dimension.  */
 349           count[n] = 0;
 350           /* We could precalculate these products, but this is a less
 351              frequently used path so probably not worth it.  */
 352           base -= sstride[n] * extent[n];
 353           mbase -= mstride[n] * extent[n];
 354           dest -= dstride[n] * extent[n];
 355           n++;
 356           if (n == rank)
 357             {
 358               /* Break out of the look.  */
 359               base = NULL;
 360               break;
 361             }
 362           else
 363             {
 364               count[n]++;
 365               base += sstride[n];
 366               mbase += mstride[n];
 367               dest += dstride[n];
 368             }
 369         }
 370     }
 371 }
 372
 373
 374 extern void smaxloc1_8_r10 (gfc_array_i8 * const restrict,
 375         gfc_array_r10 * const restrict, const index_type * const restrict,
 376         GFC_LOGICAL_4 *);
 377 export_proto(smaxloc1_8_r10);
 378
 379 void
 380 smaxloc1_8_r10 (gfc_array_i8 * const restrict retarray,
 381         gfc_array_r10 * const restrict array,
 382         const index_type * const restrict pdim,
 383         GFC_LOGICAL_4 * mask)
 384 {
 385   index_type rank;
 386   index_type n;
 387   index_type dstride;
 388   GFC_INTEGER_8 *dest;
 389
 390   if (*mask)
 391     {
 392       maxloc1_8_r10 (retarray, array, pdim);
 393       return;
 394     }
 395     rank = GFC_DESCRIPTOR_RANK (array);
 396   if (rank <= 0)
 397     runtime_error ("Rank of array needs to be > 0");
 398
 399   if (retarray->data == NULL)
 400     {
 401       retarray->dim[0].lbound = 0;
 402       retarray->dim[0].ubound = rank-1;
 403       retarray->dim[0].stride = 1;
 404       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 405       retarray->offset = 0;
 406       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank);
 407     }
 408   else
 409     {
 410       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 411         runtime_error ("rank of return array does not equal 1");
 412
 413       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 414         runtime_error ("dimension of return array incorrect");
 415     }
 416
 417     dstride = retarray->dim[0].stride;
 418     dest = retarray->data;
 419
 420     for (n = 0; n < rank; n++)
 421       dest[n * dstride] = 0 ;
 422 }
 423
 424 #endif