libgfortran/generated/maxloc0_8_i4.c

   1 /* Implementation of the MAXLOC intrinsic
   2    Copyright (C) 2002-2016 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 3 of the License, or (at your option) any later version.
  11
  12 Libgfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "libgfortran.h"
  27 #include <stdlib.h>
  28 #include <limits.h>
  29
  30
  31 #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)
  32
  33
  34 extern void maxloc0_8_i4 (gfc_array_i8 * const restrict retarray,
  35         gfc_array_i4 * const restrict array);
  36 export_proto(maxloc0_8_i4);
  37
  38 void
  39 maxloc0_8_i4 (gfc_array_i8 * const restrict retarray,
  40         gfc_array_i4 * const restrict array)
  41 {
  42   index_type count[GFC_MAX_DIMENSIONS];
  43   index_type extent[GFC_MAX_DIMENSIONS];
  44   index_type sstride[GFC_MAX_DIMENSIONS];
  45   index_type dstride;
  46   const GFC_INTEGER_4 *base;
  47   GFC_INTEGER_8 * restrict dest;
  48   index_type rank;
  49   index_type n;
  50
  51   rank = GFC_DESCRIPTOR_RANK (array);
  52   if (rank <= 0)
  53     runtime_error ("Rank of array needs to be > 0");
  54
  55   if (retarray->base_addr == NULL)
  56     {
  57       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
  58       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
  59       retarray->offset = 0;
  60       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
  61     }
  62   else
  63     {
  64       if (unlikely (compile_options.bounds_check))
  65         bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
  66                                 "MAXLOC");
  67     }
  68
  69   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  70   dest = retarray->base_addr;
  71   for (n = 0; n < rank; n++)
  72     {
  73       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  74       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  75       count[n] = 0;
  76       if (extent[n] <= 0)
  77         {
  78           /* Set the return value.  */
  79           for (n = 0; n < rank; n++)
  80             dest[n * dstride] = 0;
  81           return;
  82         }
  83     }
  84
  85   base = array->base_addr;
  86
  87   /* Initialize the return value.  */
  88   for (n = 0; n < rank; n++)
  89     dest[n * dstride] = 1;
  90   {
  91
  92     GFC_INTEGER_4 maxval;
  93 #if defined(GFC_INTEGER_4_QUIET_NAN)
  94     int fast = 0;
  95 #endif
  96
  97 #if defined(GFC_INTEGER_4_INFINITY)
  98     maxval = -GFC_INTEGER_4_INFINITY;
  99 #else
 100     maxval = (-GFC_INTEGER_4_HUGE-1);
 101 #endif
 102   while (base)
 103     {
 104       do
 105         {
 106           /* Implementation start.  */
 107
 108 #if defined(GFC_INTEGER_4_QUIET_NAN)
 109         }
 110       while (0);
 111       if (unlikely (!fast))
 112         {
 113           do
 114             {
 115               if (*base >= maxval)
 116                 {
 117                   fast = 1;
 118                   maxval = *base;
 119                   for (n = 0; n < rank; n++)
 120                     dest[n * dstride] = count[n] + 1;
 121                   break;
 122                 }
 123               base += sstride[0];
 124             }
 125           while (++count[0] != extent[0]);
 126           if (likely (fast))
 127             continue;
 128         }
 129       else do
 130         {
 131 #endif
 132           if (*base > maxval)
 133             {
 134               maxval = *base;
 135               for (n = 0; n < rank; n++)
 136                 dest[n * dstride] = count[n] + 1;
 137             }
 138           /* Implementation end.  */
 139           /* Advance to the next element.  */
 140           base += sstride[0];
 141         }
 142       while (++count[0] != extent[0]);
 143       n = 0;
 144       do
 145         {
 146           /* When we get to the end of a dimension, reset it and increment
 147              the next dimension.  */
 148           count[n] = 0;
 149           /* We could precalculate these products, but this is a less
 150              frequently used path so probably not worth it.  */
 151           base -= sstride[n] * extent[n];
 152           n++;
 153           if (n == rank)
 154             {
 155               /* Break out of the loop.  */
 156               base = NULL;
 157               break;
 158             }
 159           else
 160             {
 161               count[n]++;
 162               base += sstride[n];
 163             }
 164         }
 165       while (count[n] == extent[n]);
 166     }
 167   }
 168 }
 169
 170
 171 extern void mmaxloc0_8_i4 (gfc_array_i8 * const restrict,
 172         gfc_array_i4 * const restrict, gfc_array_l1 * const restrict);
 173 export_proto(mmaxloc0_8_i4);
 174
 175 void
 176 mmaxloc0_8_i4 (gfc_array_i8 * const restrict retarray,
 177         gfc_array_i4 * const restrict array,
 178         gfc_array_l1 * const restrict mask)
 179 {
 180   index_type count[GFC_MAX_DIMENSIONS];
 181   index_type extent[GFC_MAX_DIMENSIONS];
 182   index_type sstride[GFC_MAX_DIMENSIONS];
 183   index_type mstride[GFC_MAX_DIMENSIONS];
 184   index_type dstride;
 185   GFC_INTEGER_8 *dest;
 186   const GFC_INTEGER_4 *base;
 187   GFC_LOGICAL_1 *mbase;
 188   int rank;
 189   index_type n;
 190   int mask_kind;
 191
 192   rank = GFC_DESCRIPTOR_RANK (array);
 193   if (rank <= 0)
 194     runtime_error ("Rank of array needs to be > 0");
 195
 196   if (retarray->base_addr == NULL)
 197     {
 198       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
 199       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 200       retarray->offset = 0;
 201       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
 202     }
 203   else
 204     {
 205       if (unlikely (compile_options.bounds_check))
 206         {
 207
 208           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 209                                   "MAXLOC");
 210           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 211                                   "MASK argument", "MAXLOC");
 212         }
 213     }
 214
 215   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 216
 217   mbase = mask->base_addr;
 218
 219   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 220 #ifdef HAVE_GFC_LOGICAL_16
 221       || mask_kind == 16
 222 #endif
 223       )
 224     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 225   else
 226     runtime_error ("Funny sized logical array");
 227
 228   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 229   dest = retarray->base_addr;
 230   for (n = 0; n < rank; n++)
 231     {
 232       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 233       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 234       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 235       count[n] = 0;
 236       if (extent[n] <= 0)
 237         {
 238           /* Set the return value.  */
 239           for (n = 0; n < rank; n++)
 240             dest[n * dstride] = 0;
 241           return;
 242         }
 243     }
 244
 245   base = array->base_addr;
 246
 247   /* Initialize the return value.  */
 248   for (n = 0; n < rank; n++)
 249     dest[n * dstride] = 0;
 250   {
 251
 252   GFC_INTEGER_4 maxval;
 253    int fast = 0;
 254
 255 #if defined(GFC_INTEGER_4_INFINITY)
 256     maxval = -GFC_INTEGER_4_INFINITY;
 257 #else
 258     maxval = (-GFC_INTEGER_4_HUGE-1);
 259 #endif
 260   while (base)
 261     {
 262       do
 263         {
 264           /* Implementation start.  */
 265
 266         }
 267       while (0);
 268       if (unlikely (!fast))
 269         {
 270           do
 271             {
 272               if (*mbase)
 273                 {
 274 #if defined(GFC_INTEGER_4_QUIET_NAN)
 275                   if (unlikely (dest[0] == 0))
 276                     for (n = 0; n < rank; n++)
 277                       dest[n * dstride] = count[n] + 1;
 278                   if (*base >= maxval)
 279 #endif
 280                     {
 281                       fast = 1;
 282                       maxval = *base;
 283                       for (n = 0; n < rank; n++)
 284                         dest[n * dstride] = count[n] + 1;
 285                       break;
 286                     }
 287                 }
 288               base += sstride[0];
 289               mbase += mstride[0];
 290             }
 291           while (++count[0] != extent[0]);
 292           if (likely (fast))
 293             continue;
 294         }
 295       else do
 296         {
 297           if (*mbase && *base > maxval)
 298             {
 299               maxval = *base;
 300               for (n = 0; n < rank; n++)
 301                 dest[n * dstride] = count[n] + 1;
 302             }
 303           /* Implementation end.  */
 304           /* Advance to the next element.  */
 305           base += sstride[0];
 306           mbase += mstride[0];
 307         }
 308       while (++count[0] != extent[0]);
 309       n = 0;
 310       do
 311         {
 312           /* When we get to the end of a dimension, reset it and increment
 313              the next dimension.  */
 314           count[n] = 0;
 315           /* We could precalculate these products, but this is a less
 316              frequently used path so probably not worth it.  */
 317           base -= sstride[n] * extent[n];
 318           mbase -= mstride[n] * extent[n];
 319           n++;
 320           if (n == rank)
 321             {
 322               /* Break out of the loop.  */
 323               base = NULL;
 324               break;
 325             }
 326           else
 327             {
 328               count[n]++;
 329               base += sstride[n];
 330               mbase += mstride[n];
 331             }
 332         }
 333       while (count[n] == extent[n]);
 334     }
 335   }
 336 }
 337
 338
 339 extern void smaxloc0_8_i4 (gfc_array_i8 * const restrict,
 340         gfc_array_i4 * const restrict, GFC_LOGICAL_4 *);
 341 export_proto(smaxloc0_8_i4);
 342
 343 void
 344 smaxloc0_8_i4 (gfc_array_i8 * const restrict retarray,
 345         gfc_array_i4 * const restrict array,
 346         GFC_LOGICAL_4 * mask)
 347 {
 348   index_type rank;
 349   index_type dstride;
 350   index_type n;
 351   GFC_INTEGER_8 *dest;
 352
 353   if (*mask)
 354     {
 355       maxloc0_8_i4 (retarray, array);
 356       return;
 357     }
 358
 359   rank = GFC_DESCRIPTOR_RANK (array);
 360
 361   if (rank <= 0)
 362     runtime_error ("Rank of array needs to be > 0");
 363
 364   if (retarray->base_addr == NULL)
 365     {
 366       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 367       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 368       retarray->offset = 0;
 369       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
 370     }
 371   else if (unlikely (compile_options.bounds_check))
 372     {
 373        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 374                                "MAXLOC");
 375     }
 376
 377   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 378   dest = retarray->base_addr;
 379   for (n = 0; n<rank; n++)
 380     dest[n * dstride] = 0 ;
 381 }
 382 #endif