libgfortran/generated/minloc0_4_r16.c

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