libgfortran/generated/minloc0_4_r4.c

   1 /* Implementation of the MINLOC intrinsic
   2    Copyright (C) 2002-2018 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 <assert.h>
  28
  29
  30 #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4)
  31
  32
  33 extern void minloc0_4_r4 (gfc_array_i4 * const restrict retarray,
  34         gfc_array_r4 * const restrict array, GFC_LOGICAL_4);
  35 export_proto(minloc0_4_r4);
  36
  37 void
  38 minloc0_4_r4 (gfc_array_i4 * const restrict retarray,
  39         gfc_array_r4 * const restrict array, GFC_LOGICAL_4 back)
  40 {
  41   index_type count[GFC_MAX_DIMENSIONS];
  42   index_type extent[GFC_MAX_DIMENSIONS];
  43   index_type sstride[GFC_MAX_DIMENSIONS];
  44   index_type dstride;
  45   const GFC_REAL_4 *base;
  46   GFC_INTEGER_4 * restrict dest;
  47   index_type rank;
  48   index_type n;
  49
  50   assert(back == 0);
  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       GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
  59       retarray->offset = 0;
  60       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
  61     }
  62   else
  63     {
  64       if (unlikely (compile_options.bounds_check))
  65         bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
  66                                 "MINLOC");
  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_REAL_4 minval;
  93 #if defined(GFC_REAL_4_QUIET_NAN)
  94     int fast = 0;
  95 #endif
  96
  97 #if defined(GFC_REAL_4_INFINITY)
  98     minval = GFC_REAL_4_INFINITY;
  99 #else
 100     minval = GFC_REAL_4_HUGE;
 101 #endif
 102   while (base)
 103     {
 104       do
 105         {
 106           /* Implementation start.  */
 107
 108 #if defined(GFC_REAL_4_QUIET_NAN)
 109         }
 110       while (0);
 111       if (unlikely (!fast))
 112         {
 113           do
 114             {
 115               if (*base <= minval)
 116                 {
 117                   fast = 1;
 118                   minval = *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 < minval)
 133             {
 134               minval = *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 mminloc0_4_r4 (gfc_array_i4 * const restrict,
 172         gfc_array_r4 * const restrict, gfc_array_l1 * const restrict,
 173         GFC_LOGICAL_4);
 174 export_proto(mminloc0_4_r4);
 175
 176 void
 177 mminloc0_4_r4 (gfc_array_i4 * const restrict retarray,
 178         gfc_array_r4 * const restrict array,
 179         gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
 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_4 *base;
 188   GFC_LOGICAL_1 *mbase;
 189   int rank;
 190   index_type n;
 191   int mask_kind;
 192
 193   assert(back == 0);
 194   rank = GFC_DESCRIPTOR_RANK (array);
 195   if (rank <= 0)
 196     runtime_error ("Rank of array needs to be > 0");
 197
 198   if (retarray->base_addr == NULL)
 199     {
 200       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
 201       GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
 202       retarray->offset = 0;
 203       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
 204     }
 205   else
 206     {
 207       if (unlikely (compile_options.bounds_check))
 208         {
 209
 210           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 211                                   "MINLOC");
 212           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 213                                   "MASK argument", "MINLOC");
 214         }
 215     }
 216
 217   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 218
 219   mbase = mask->base_addr;
 220
 221   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 222 #ifdef HAVE_GFC_LOGICAL_16
 223       || mask_kind == 16
 224 #endif
 225       )
 226     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 227   else
 228     runtime_error ("Funny sized logical array");
 229
 230   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 231   dest = retarray->base_addr;
 232   for (n = 0; n < rank; n++)
 233     {
 234       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 235       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 236       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 237       count[n] = 0;
 238       if (extent[n] <= 0)
 239         {
 240           /* Set the return value.  */
 241           for (n = 0; n < rank; n++)
 242             dest[n * dstride] = 0;
 243           return;
 244         }
 245     }
 246
 247   base = array->base_addr;
 248
 249   /* Initialize the return value.  */
 250   for (n = 0; n < rank; n++)
 251     dest[n * dstride] = 0;
 252   {
 253
 254   GFC_REAL_4 minval;
 255    int fast = 0;
 256
 257 #if defined(GFC_REAL_4_INFINITY)
 258     minval = GFC_REAL_4_INFINITY;
 259 #else
 260     minval = GFC_REAL_4_HUGE;
 261 #endif
 262   while (base)
 263     {
 264       do
 265         {
 266           /* Implementation start.  */
 267
 268         }
 269       while (0);
 270       if (unlikely (!fast))
 271         {
 272           do
 273             {
 274               if (*mbase)
 275                 {
 276 #if defined(GFC_REAL_4_QUIET_NAN)
 277                   if (unlikely (dest[0] == 0))
 278                     for (n = 0; n < rank; n++)
 279                       dest[n * dstride] = count[n] + 1;
 280                   if (*base <= minval)
 281 #endif
 282                     {
 283                       fast = 1;
 284                       minval = *base;
 285                       for (n = 0; n < rank; n++)
 286                         dest[n * dstride] = count[n] + 1;
 287                       break;
 288                     }
 289                 }
 290               base += sstride[0];
 291               mbase += mstride[0];
 292             }
 293           while (++count[0] != extent[0]);
 294           if (likely (fast))
 295             continue;
 296         }
 297       else do
 298         {
 299           if (*mbase && *base < minval)
 300             {
 301               minval = *base;
 302               for (n = 0; n < rank; n++)
 303                 dest[n * dstride] = count[n] + 1;
 304             }
 305           /* Implementation end.  */
 306           /* Advance to the next element.  */
 307           base += sstride[0];
 308           mbase += mstride[0];
 309         }
 310       while (++count[0] != extent[0]);
 311       n = 0;
 312       do
 313         {
 314           /* When we get to the end of a dimension, reset it and increment
 315              the next dimension.  */
 316           count[n] = 0;
 317           /* We could precalculate these products, but this is a less
 318              frequently used path so probably not worth it.  */
 319           base -= sstride[n] * extent[n];
 320           mbase -= mstride[n] * extent[n];
 321           n++;
 322           if (n >= rank)
 323             {
 324               /* Break out of the loop.  */
 325               base = NULL;
 326               break;
 327             }
 328           else
 329             {
 330               count[n]++;
 331               base += sstride[n];
 332               mbase += mstride[n];
 333             }
 334         }
 335       while (count[n] == extent[n]);
 336     }
 337   }
 338 }
 339
 340
 341 extern void sminloc0_4_r4 (gfc_array_i4 * const restrict,
 342         gfc_array_r4 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
 343 export_proto(sminloc0_4_r4);
 344
 345 void
 346 sminloc0_4_r4 (gfc_array_i4 * const restrict retarray,
 347         gfc_array_r4 * const restrict array,
 348         GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
 349 {
 350   index_type rank;
 351   index_type dstride;
 352   index_type n;
 353   GFC_INTEGER_4 *dest;
 354
 355   if (*mask)
 356     {
 357       minloc0_4_r4 (retarray, array, back);
 358       return;
 359     }
 360
 361   rank = GFC_DESCRIPTOR_RANK (array);
 362
 363   if (rank <= 0)
 364     runtime_error ("Rank of array needs to be > 0");
 365
 366   if (retarray->base_addr == NULL)
 367     {
 368       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 369       GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
 370       retarray->offset = 0;
 371       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
 372     }
 373   else if (unlikely (compile_options.bounds_check))
 374     {
 375        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 376                                "MINLOC");
 377     }
 378
 379   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 380   dest = retarray->base_addr;
 381   for (n = 0; n<rank; n++)
 382     dest[n * dstride] = 0 ;
 383 }
 384 #endif