libgfortran/generated/minloc0_8_r4.c

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