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