libgfortran/generated/maxloc1_16_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_16)
  39
  40
  41 extern void maxloc1_16_r10 (gfc_array_i16 * const restrict,
  42         gfc_array_r10 * const restrict, const index_type * const restrict);
  43 export_proto(maxloc1_16_r10);
  44
  45 void
  46 maxloc1_16_r10 (gfc_array_i16 * 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_16 * 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_16) * 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_16 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_16)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_16_r10 (gfc_array_i16 * const restrict,
 193         gfc_array_r10 * const restrict, const index_type * const restrict,
 194         gfc_array_l4 * const restrict);
 195 export_proto(mmaxloc1_16_r10);
 196
 197 void
 198 mmaxloc1_16_r10 (gfc_array_i16 * const restrict retarray,
 199         gfc_array_r10 * const restrict array,
 200         const index_type * const restrict pdim,
 201         gfc_array_l4 * 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_16 * restrict dest;
 209   const GFC_REAL_10 * restrict base;
 210   const GFC_LOGICAL_4 * 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
 218   dim = (*pdim) - 1;
 219   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 220
 221   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 222   if (len <= 0)
 223     return;
 224   delta = array->dim[dim].stride;
 225   mdelta = mask->dim[dim].stride;
 226
 227   for (n = 0; n < dim; n++)
 228     {
 229       sstride[n] = array->dim[n].stride;
 230       mstride[n] = mask->dim[n].stride;
 231       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 232
 233       if (extent[n] < 0)
 234         extent[n] = 0;
 235
 236     }
 237   for (n = dim; n < rank; n++)
 238     {
 239       sstride[n] = array->dim[n + 1].stride;
 240       mstride[n] = mask->dim[n + 1].stride;
 241       extent[n] =
 242         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 243
 244       if (extent[n] < 0)
 245         extent[n] = 0;
 246     }
 247
 248   if (retarray->data == NULL)
 249     {
 250       size_t alloc_size;
 251
 252       for (n = 0; n < rank; n++)
 253         {
 254           retarray->dim[n].lbound = 0;
 255           retarray->dim[n].ubound = extent[n]-1;
 256           if (n == 0)
 257             retarray->dim[n].stride = 1;
 258           else
 259             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 260         }
 261
 262       alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride
 263                    * extent[rank-1];
 264
 265       retarray->offset = 0;
 266       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 267
 268       if (alloc_size == 0)
 269         {
 270           /* Make sure we have a zero-sized array.  */
 271           retarray->dim[0].lbound = 0;
 272           retarray->dim[0].ubound = -1;
 273           return;
 274         }
 275       else
 276         retarray->data = internal_malloc_size (alloc_size);
 277
 278     }
 279   else
 280     {
 281       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 282         runtime_error ("rank of return array incorrect");
 283     }
 284
 285   for (n = 0; n < rank; n++)
 286     {
 287       count[n] = 0;
 288       dstride[n] = retarray->dim[n].stride;
 289       if (extent[n] <= 0)
 290         return;
 291     }
 292
 293   dest = retarray->data;
 294   base = array->data;
 295   mbase = mask->data;
 296
 297   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 298     {
 299       /* This allows the same loop to be used for all logical types.  */
 300       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 301       for (n = 0; n < rank; n++)
 302         mstride[n] <<= 1;
 303       mdelta <<= 1;
 304       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 305     }
 306
 307   while (base)
 308     {
 309       const GFC_REAL_10 * restrict src;
 310       const GFC_LOGICAL_4 * restrict msrc;
 311       GFC_INTEGER_16 result;
 312       src = base;
 313       msrc = mbase;
 314       {
 315
 316   GFC_REAL_10 maxval;
 317   maxval = -GFC_REAL_10_HUGE;
 318   result = 0;
 319         if (len <= 0)
 320           *dest = 0;
 321         else
 322           {
 323             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 324               {
 325
 326   if (*msrc && (*src > maxval || !result))
 327     {
 328       maxval = *src;
 329       result = (GFC_INTEGER_16)n + 1;
 330     }
 331               }
 332             *dest = result;
 333           }
 334       }
 335       /* Advance to the next element.  */
 336       count[0]++;
 337       base += sstride[0];
 338       mbase += mstride[0];
 339       dest += dstride[0];
 340       n = 0;
 341       while (count[n] == extent[n])
 342         {
 343           /* When we get to the end of a dimension, reset it and increment
 344              the next dimension.  */
 345           count[n] = 0;
 346           /* We could precalculate these products, but this is a less
 347              frequently used path so probably not worth it.  */
 348           base -= sstride[n] * extent[n];
 349           mbase -= mstride[n] * extent[n];
 350           dest -= dstride[n] * extent[n];
 351           n++;
 352           if (n == rank)
 353             {
 354               /* Break out of the look.  */
 355               base = NULL;
 356               break;
 357             }
 358           else
 359             {
 360               count[n]++;
 361               base += sstride[n];
 362               mbase += mstride[n];
 363               dest += dstride[n];
 364             }
 365         }
 366     }
 367 }
 368
 369
 370 extern void smaxloc1_16_r10 (gfc_array_i16 * const restrict,
 371         gfc_array_r10 * const restrict, const index_type * const restrict,
 372         GFC_LOGICAL_4 *);
 373 export_proto(smaxloc1_16_r10);
 374
 375 void
 376 smaxloc1_16_r10 (gfc_array_i16 * const restrict retarray,
 377         gfc_array_r10 * const restrict array,
 378         const index_type * const restrict pdim,
 379         GFC_LOGICAL_4 * mask)
 380 {
 381   index_type rank;
 382   index_type n;
 383   index_type dstride;
 384   GFC_INTEGER_16 *dest;
 385
 386   if (*mask)
 387     {
 388       maxloc1_16_r10 (retarray, array, pdim);
 389       return;
 390     }
 391     rank = GFC_DESCRIPTOR_RANK (array);
 392   if (rank <= 0)
 393     runtime_error ("Rank of array needs to be > 0");
 394
 395   if (retarray->data == NULL)
 396     {
 397       retarray->dim[0].lbound = 0;
 398       retarray->dim[0].ubound = rank-1;
 399       retarray->dim[0].stride = 1;
 400       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 401       retarray->offset = 0;
 402       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
 403     }
 404   else
 405     {
 406       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 407         runtime_error ("rank of return array does not equal 1");
 408
 409       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 410         runtime_error ("dimension of return array incorrect");
 411     }
 412
 413     dstride = retarray->dim[0].stride;
 414     dest = retarray->data;
 415
 416     for (n = 0; n < rank; n++)
 417       dest[n * dstride] = 0 ;
 418 }
 419
 420 #endif