libgfortran/generated/minloc0_4_r17.c

   1 /* Implementation of the MINLOC intrinsic
   2    Copyright (C) 2002-2023 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_17) && defined (HAVE_GFC_INTEGER_4)
  31
  32
  33 extern void minloc0_4_r17 (gfc_array_i4 * const restrict retarray,
  34         gfc_array_r17 * const restrict array, GFC_LOGICAL_4);
  35 export_proto(minloc0_4_r17);
  36
  37 void
  38 minloc0_4_r17 (gfc_array_i4 * const restrict retarray,
  39         gfc_array_r17 * 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_17 *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_17 minval;
  92 #if defined(GFC_REAL_17_QUIET_NAN)
  93     int fast = 0;
  94 #endif
  95
  96 #if defined(GFC_REAL_17_INFINITY)
  97     minval = GFC_REAL_17_INFINITY;
  98 #else
  99     minval = GFC_REAL_17_HUGE;
 100 #endif
 101   while (base)
 102     {
 103           /* Implementation start.  */
 104
 105 #if defined(GFC_REAL_17_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_r17 (gfc_array_i4 * const restrict,
 180         gfc_array_r17 * const restrict, gfc_array_l1 * const restrict,
 181         GFC_LOGICAL_4);
 182 export_proto(mminloc0_4_r17);
 183
 184 void
 185 mminloc0_4_r17 (gfc_array_i4 * const restrict retarray,
 186         gfc_array_r17 * 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_17 *base;
 196   GFC_LOGICAL_1 *mbase;
 197   int rank;
 198   index_type n;
 199   int mask_kind;
 200
 201
 202   if (mask == NULL)
 203     {
 204       minloc0_4_r17 (retarray, array, back);
 205       return;
 206     }
 207
 208   rank = GFC_DESCRIPTOR_RANK (array);
 209   if (rank <= 0)
 210     runtime_error ("Rank of array needs to be > 0");
 211
 212   if (retarray->base_addr == NULL)
 213     {
 214       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
 215       retarray->dtype.rank = 1;
 216       retarray->offset = 0;
 217       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
 218     }
 219   else
 220     {
 221       if (unlikely (compile_options.bounds_check))
 222         {
 223
 224           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 225                                   "MINLOC");
 226           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 227                                   "MASK argument", "MINLOC");
 228         }
 229     }
 230
 231   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 232
 233   mbase = mask->base_addr;
 234
 235   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 236 #ifdef HAVE_GFC_LOGICAL_16
 237       || mask_kind == 16
 238 #endif
 239       )
 240     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 241   else
 242     runtime_error ("Funny sized logical array");
 243
 244   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 245   dest = retarray->base_addr;
 246   for (n = 0; n < rank; n++)
 247     {
 248       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 249       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 250       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 251       count[n] = 0;
 252       if (extent[n] <= 0)
 253         {
 254           /* Set the return value.  */
 255           for (n = 0; n < rank; n++)
 256             dest[n * dstride] = 0;
 257           return;
 258         }
 259     }
 260
 261   base = array->base_addr;
 262
 263   /* Initialize the return value.  */
 264   for (n = 0; n < rank; n++)
 265     dest[n * dstride] = 0;
 266   {
 267
 268   GFC_REAL_17 minval;
 269    int fast = 0;
 270
 271 #if defined(GFC_REAL_17_INFINITY)
 272     minval = GFC_REAL_17_INFINITY;
 273 #else
 274     minval = GFC_REAL_17_HUGE;
 275 #endif
 276   while (base)
 277     {
 278           /* Implementation start.  */
 279
 280       if (unlikely (!fast))
 281         {
 282           do
 283             {
 284               if (*mbase)
 285                 {
 286 #if defined(GFC_REAL_17_QUIET_NAN)
 287                   if (unlikely (dest[0] == 0))
 288                     for (n = 0; n < rank; n++)
 289                       dest[n * dstride] = count[n] + 1;
 290                   if (*base <= minval)
 291 #endif
 292                     {
 293                       fast = 1;
 294                       minval = *base;
 295                       for (n = 0; n < rank; n++)
 296                         dest[n * dstride] = count[n] + 1;
 297                       break;
 298                     }
 299                 }
 300               base += sstride[0];
 301               mbase += mstride[0];
 302             }
 303           while (++count[0] != extent[0]);
 304           if (likely (fast))
 305             continue;
 306         }
 307         else
 308         if (back)
 309           do
 310             {
 311               if (unlikely (*mbase && (*base <= minval)))
 312                 {
 313                   minval = *base;
 314                   for (n = 0; n < rank; n++)
 315                     dest[n * dstride] = count[n] + 1;
 316                 }
 317                 base += sstride[0];
 318             }
 319             while (++count[0] != extent[0]);
 320         else
 321           do
 322             {
 323               if (unlikely (*mbase && (*base < minval)))
 324                 {
 325                   minval = *base;
 326                   for (n = 0; n < rank; n++)
 327                     dest[n * dstride] = count[n] + 1;
 328                 }
 329           /* Implementation end.  */
 330           /* Advance to the next element.  */
 331           base += sstride[0];
 332           mbase += mstride[0];
 333         }
 334       while (++count[0] != extent[0]);
 335       n = 0;
 336       do
 337         {
 338           /* When we get to the end of a dimension, reset it and increment
 339              the next dimension.  */
 340           count[n] = 0;
 341           /* We could precalculate these products, but this is a less
 342              frequently used path so probably not worth it.  */
 343           base -= sstride[n] * extent[n];
 344           mbase -= mstride[n] * extent[n];
 345           n++;
 346           if (n >= rank)
 347             {
 348               /* Break out of the loop.  */
 349               base = NULL;
 350               break;
 351             }
 352           else
 353             {
 354               count[n]++;
 355               base += sstride[n];
 356               mbase += mstride[n];
 357             }
 358         }
 359       while (count[n] == extent[n]);
 360     }
 361   }
 362 }
 363
 364 extern void sminloc0_4_r17 (gfc_array_i4 * const restrict,
 365         gfc_array_r17 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
 366 export_proto(sminloc0_4_r17);
 367
 368 void
 369 sminloc0_4_r17 (gfc_array_i4 * const restrict retarray,
 370         gfc_array_r17 * const restrict array,
 371         GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
 372 {
 373   index_type rank;
 374   index_type dstride;
 375   index_type n;
 376   GFC_INTEGER_4 *dest;
 377
 378   if (mask == NULL || *mask)
 379     {
 380       minloc0_4_r17 (retarray, array, back);
 381       return;
 382     }
 383
 384   rank = GFC_DESCRIPTOR_RANK (array);
 385
 386   if (rank <= 0)
 387     runtime_error ("Rank of array needs to be > 0");
 388
 389   if (retarray->base_addr == NULL)
 390     {
 391       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 392       retarray->dtype.rank = 1;
 393       retarray->offset = 0;
 394       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4));
 395     }
 396   else if (unlikely (compile_options.bounds_check))
 397     {
 398        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 399                                "MINLOC");
 400     }
 401
 402   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 403   dest = retarray->base_addr;
 404   for (n = 0; n<rank; n++)
 405     dest[n * dstride] = 0 ;
 406 }
 407 #endif