libgfortran/generated/maxloc0_16_r16.c

   1 /* Implementation of the MAXLOC intrinsic
   2    Copyright (C) 2002-2024 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_16) && defined (HAVE_GFC_INTEGER_16)
  31
  32
  33 extern void maxloc0_16_r16 (gfc_array_i16 * const restrict retarray,
  34         gfc_array_r16 * const restrict array, GFC_LOGICAL_4);
  35 export_proto(maxloc0_16_r16);
  36
  37 void
  38 maxloc0_16_r16 (gfc_array_i16 * const restrict retarray,
  39         gfc_array_r16 * 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_16 *base;
  46   GFC_INTEGER_16 * 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_16));
  60     }
  61   else
  62     {
  63       if (unlikely (compile_options.bounds_check))
  64         bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
  65                                 "MAXLOC");
  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_16 maxval;
  92 #if defined(GFC_REAL_16_QUIET_NAN)
  93     int fast = 0;
  94 #endif
  95
  96 #if defined(GFC_REAL_16_INFINITY)
  97     maxval = -GFC_REAL_16_INFINITY;
  98 #else
  99     maxval = -GFC_REAL_16_HUGE;
 100 #endif
 101   while (base)
 102     {
 103           /* Implementation start.  */
 104
 105 #if defined(GFC_REAL_16_QUIET_NAN)
 106       if (unlikely (!fast))
 107         {
 108           do
 109             {
 110               if (*base >= maxval)
 111                 {
 112                   fast = 1;
 113                   maxval = *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 >= maxval))
 130                {
 131                  maxval = *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 > maxval))
 142                {
 143                  maxval = *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 mmaxloc0_16_r16 (gfc_array_i16 * const restrict,
 180         gfc_array_r16 * const restrict, gfc_array_l1 * const restrict,
 181         GFC_LOGICAL_4);
 182 export_proto(mmaxloc0_16_r16);
 183
 184 void
 185 mmaxloc0_16_r16 (gfc_array_i16 * const restrict retarray,
 186         gfc_array_r16 * 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_16 *dest;
 195   const GFC_REAL_16 *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       maxloc0_16_r16 (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_16));
 218     }
 219   else
 220     {
 221       if (unlikely (compile_options.bounds_check))
 222         {
 223
 224           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 225                                   "MAXLOC");
 226           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 227                                   "MASK argument", "MAXLOC");
 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_16 maxval;
 269    int fast = 0;
 270
 271 #if defined(GFC_REAL_16_INFINITY)
 272     maxval = -GFC_REAL_16_INFINITY;
 273 #else
 274     maxval = -GFC_REAL_16_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_16_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 >= maxval)
 291 #endif
 292                     {
 293                       fast = 1;
 294                       maxval = *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 (*mbase && *base >= maxval)
 312                 {
 313                   maxval = *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 (*mbase && unlikely (*base > maxval))
 324                 {
 325                   maxval = *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
 365 extern void smaxloc0_16_r16 (gfc_array_i16 * const restrict,
 366         gfc_array_r16 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
 367 export_proto(smaxloc0_16_r16);
 368
 369 void
 370 smaxloc0_16_r16 (gfc_array_i16 * const restrict retarray,
 371         gfc_array_r16 * const restrict array,
 372         GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
 373 {
 374   index_type rank;
 375   index_type dstride;
 376   index_type n;
 377   GFC_INTEGER_16 *dest;
 378
 379   if (mask == NULL || *mask)
 380     {
 381       maxloc0_16_r16 (retarray, array, back);
 382       return;
 383     }
 384
 385   rank = GFC_DESCRIPTOR_RANK (array);
 386
 387   if (rank <= 0)
 388     runtime_error ("Rank of array needs to be > 0");
 389
 390   if (retarray->base_addr == NULL)
 391     {
 392       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 393       retarray->dtype.rank = 1;
 394       retarray->offset = 0;
 395       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_16));
 396     }
 397   else if (unlikely (compile_options.bounds_check))
 398     {
 399        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 400                                "MAXLOC");
 401     }
 402
 403   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 404   dest = retarray->base_addr;
 405   for (n = 0; n<rank; n++)
 406     dest[n * dstride] = 0 ;
 407 }
 408 #endif