libgfortran/generated/maxloc0_8_r16.c

   1 /* Implementation of the MAXLOC 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_16) && defined (HAVE_GFC_INTEGER_8)
  31
  32
  33 extern void maxloc0_8_r16 (gfc_array_i8 * const restrict retarray,
  34         gfc_array_r16 * const restrict array, GFC_LOGICAL_4);
  35 export_proto(maxloc0_8_r16);
  36
  37 void
  38 maxloc0_8_r16 (gfc_array_i8 * 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_8 * 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_8));
  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_8_r16 (gfc_array_i8 * const restrict,
 180         gfc_array_r16 * const restrict, gfc_array_l1 * const restrict,
 181         GFC_LOGICAL_4);
 182 export_proto(mmaxloc0_8_r16);
 183
 184 void
 185 mmaxloc0_8_r16 (gfc_array_i8 * 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_8 *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   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_8));
 211     }
 212   else
 213     {
 214       if (unlikely (compile_options.bounds_check))
 215         {
 216
 217           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 218                                   "MAXLOC");
 219           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 220                                   "MASK argument", "MAXLOC");
 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_16 maxval;
 262    int fast = 0;
 263
 264 #if defined(GFC_REAL_16_INFINITY)
 265     maxval = -GFC_REAL_16_INFINITY;
 266 #else
 267     maxval = -GFC_REAL_16_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_16_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 >= maxval)
 284 #endif
 285                     {
 286                       fast = 1;
 287                       maxval = *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 (*mbase && *base >= maxval)
 305                 {
 306                   maxval = *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 (*mbase && unlikely (*base > maxval))
 317                 {
 318                   maxval = *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
 358 extern void smaxloc0_8_r16 (gfc_array_i8 * const restrict,
 359         gfc_array_r16 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4);
 360 export_proto(smaxloc0_8_r16);
 361
 362 void
 363 smaxloc0_8_r16 (gfc_array_i8 * const restrict retarray,
 364         gfc_array_r16 * const restrict array,
 365         GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
 366 {
 367   index_type rank;
 368   index_type dstride;
 369   index_type n;
 370   GFC_INTEGER_8 *dest;
 371
 372   if (*mask)
 373     {
 374       maxloc0_8_r16 (retarray, array, back);
 375       return;
 376     }
 377
 378   rank = GFC_DESCRIPTOR_RANK (array);
 379
 380   if (rank <= 0)
 381     runtime_error ("Rank of array needs to be > 0");
 382
 383   if (retarray->base_addr == NULL)
 384     {
 385       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 386       retarray->dtype.rank = 1;
 387       retarray->offset = 0;
 388       retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
 389     }
 390   else if (unlikely (compile_options.bounds_check))
 391     {
 392        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 393                                "MAXLOC");
 394     }
 395
 396   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 397   dest = retarray->base_addr;
 398   for (n = 0; n<rank; n++)
 399     dest[n * dstride] = 0 ;
 400 }
 401 #endif