libgfortran/generated/minloc1_4_i2.c

   1 /* Implementation of the MINLOC intrinsic
   2    Copyright 2002, 2007, 2009 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 <stdlib.h>
  28 #include <assert.h>
  29 #include <limits.h>
  30
  31
  32 #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4)
  33
  34
  35 extern void minloc1_4_i2 (gfc_array_i4 * const restrict,
  36         gfc_array_i2 * const restrict, const index_type * const restrict);
  37 export_proto(minloc1_4_i2);
  38
  39 void
  40 minloc1_4_i2 (gfc_array_i4 * const restrict retarray,
  41         gfc_array_i2 * const restrict array,
  42         const index_type * const restrict pdim)
  43 {
  44   index_type count[GFC_MAX_DIMENSIONS];
  45   index_type extent[GFC_MAX_DIMENSIONS];
  46   index_type sstride[GFC_MAX_DIMENSIONS];
  47   index_type dstride[GFC_MAX_DIMENSIONS];
  48   const GFC_INTEGER_2 * restrict base;
  49   GFC_INTEGER_4 * restrict dest;
  50   index_type rank;
  51   index_type n;
  52   index_type len;
  53   index_type delta;
  54   index_type dim;
  55   int continue_loop;
  56
  57   /* Make dim zero based to avoid confusion.  */
  58   dim = (*pdim) - 1;
  59   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  60
  61   len = GFC_DESCRIPTOR_EXTENT(array,dim);
  62   if (len < 0)
  63     len = 0;
  64   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  65
  66   for (n = 0; n < dim; n++)
  67     {
  68       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  69       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  70
  71       if (extent[n] < 0)
  72         extent[n] = 0;
  73     }
  74   for (n = dim; n < rank; n++)
  75     {
  76       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
  77       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
  78
  79       if (extent[n] < 0)
  80         extent[n] = 0;
  81     }
  82
  83   if (retarray->data == NULL)
  84     {
  85       size_t alloc_size, str;
  86
  87       for (n = 0; n < rank; n++)
  88         {
  89           if (n == 0)
  90             str = 1;
  91           else
  92             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
  93
  94           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
  95
  96         }
  97
  98       retarray->offset = 0;
  99       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 100
 101       alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 102                    * extent[rank-1];
 103
 104       if (alloc_size == 0)
 105         {
 106           /* Make sure we have a zero-sized array.  */
 107           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 108           return;
 109
 110         }
 111       else
 112         retarray->data = internal_malloc_size (alloc_size);
 113     }
 114   else
 115     {
 116       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 117         runtime_error ("rank of return array incorrect in"
 118                        " MINLOC intrinsic: is %ld, should be %ld",
 119                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 120                        (long int) rank);
 121
 122       if (unlikely (compile_options.bounds_check))
 123         bounds_ifunction_return ((array_t *) retarray, extent,
 124                                  "return value", "MINLOC");
 125     }
 126
 127   for (n = 0; n < rank; n++)
 128     {
 129       count[n] = 0;
 130       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 131       if (extent[n] <= 0)
 132         len = 0;
 133     }
 134
 135   base = array->data;
 136   dest = retarray->data;
 137
 138   continue_loop = 1;
 139   while (continue_loop)
 140     {
 141       const GFC_INTEGER_2 * restrict src;
 142       GFC_INTEGER_4 result;
 143       src = base;
 144       {
 145
 146         GFC_INTEGER_2 minval;
 147 #if defined (GFC_INTEGER_2_INFINITY)
 148         minval = GFC_INTEGER_2_INFINITY;
 149 #else
 150         minval = GFC_INTEGER_2_HUGE;
 151 #endif
 152         result = 1;
 153         if (len <= 0)
 154           *dest = 0;
 155         else
 156           {
 157             for (n = 0; n < len; n++, src += delta)
 158               {
 159
 160 #if defined (GFC_INTEGER_2_QUIET_NAN)
 161                 if (*src <= minval)
 162                   {
 163                     minval = *src;
 164                     result = (GFC_INTEGER_4)n + 1;
 165                     break;
 166                   }
 167               }
 168             for (; n < len; n++, src += delta)
 169               {
 170 #endif
 171                 if (*src < minval)
 172                   {
 173                     minval = *src;
 174                     result = (GFC_INTEGER_4)n + 1;
 175                   }
 176               }
 177             *dest = result;
 178           }
 179       }
 180       /* Advance to the next element.  */
 181       count[0]++;
 182       base += sstride[0];
 183       dest += dstride[0];
 184       n = 0;
 185       while (count[n] == extent[n])
 186         {
 187           /* When we get to the end of a dimension, reset it and increment
 188              the next dimension.  */
 189           count[n] = 0;
 190           /* We could precalculate these products, but this is a less
 191              frequently used path so probably not worth it.  */
 192           base -= sstride[n] * extent[n];
 193           dest -= dstride[n] * extent[n];
 194           n++;
 195           if (n == rank)
 196             {
 197               /* Break out of the look.  */
 198               continue_loop = 0;
 199               break;
 200             }
 201           else
 202             {
 203               count[n]++;
 204               base += sstride[n];
 205               dest += dstride[n];
 206             }
 207         }
 208     }
 209 }
 210
 211
 212 extern void mminloc1_4_i2 (gfc_array_i4 * const restrict,
 213         gfc_array_i2 * const restrict, const index_type * const restrict,
 214         gfc_array_l1 * const restrict);
 215 export_proto(mminloc1_4_i2);
 216
 217 void
 218 mminloc1_4_i2 (gfc_array_i4 * const restrict retarray,
 219         gfc_array_i2 * const restrict array,
 220         const index_type * const restrict pdim,
 221         gfc_array_l1 * const restrict mask)
 222 {
 223   index_type count[GFC_MAX_DIMENSIONS];
 224   index_type extent[GFC_MAX_DIMENSIONS];
 225   index_type sstride[GFC_MAX_DIMENSIONS];
 226   index_type dstride[GFC_MAX_DIMENSIONS];
 227   index_type mstride[GFC_MAX_DIMENSIONS];
 228   GFC_INTEGER_4 * restrict dest;
 229   const GFC_INTEGER_2 * restrict base;
 230   const GFC_LOGICAL_1 * restrict mbase;
 231   int rank;
 232   int dim;
 233   index_type n;
 234   index_type len;
 235   index_type delta;
 236   index_type mdelta;
 237   int mask_kind;
 238
 239   dim = (*pdim) - 1;
 240   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 241
 242   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 243   if (len <= 0)
 244     return;
 245
 246   mbase = mask->data;
 247
 248   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 249
 250   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 251 #ifdef HAVE_GFC_LOGICAL_16
 252       || mask_kind == 16
 253 #endif
 254       )
 255     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 256   else
 257     runtime_error ("Funny sized logical array");
 258
 259   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 260   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 261
 262   for (n = 0; n < dim; n++)
 263     {
 264       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 265       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 266       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 267
 268       if (extent[n] < 0)
 269         extent[n] = 0;
 270
 271     }
 272   for (n = dim; n < rank; n++)
 273     {
 274       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 275       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 276       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 277
 278       if (extent[n] < 0)
 279         extent[n] = 0;
 280     }
 281
 282   if (retarray->data == NULL)
 283     {
 284       size_t alloc_size, str;
 285
 286       for (n = 0; n < rank; n++)
 287         {
 288           if (n == 0)
 289             str = 1;
 290           else
 291             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 292
 293           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 294
 295         }
 296
 297       alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 298                    * extent[rank-1];
 299
 300       retarray->offset = 0;
 301       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 302
 303       if (alloc_size == 0)
 304         {
 305           /* Make sure we have a zero-sized array.  */
 306           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 307           return;
 308         }
 309       else
 310         retarray->data = internal_malloc_size (alloc_size);
 311
 312     }
 313   else
 314     {
 315       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 316         runtime_error ("rank of return array incorrect in MINLOC intrinsic");
 317
 318       if (unlikely (compile_options.bounds_check))
 319         {
 320           bounds_ifunction_return ((array_t *) retarray, extent,
 321                                    "return value", "MINLOC");
 322           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 323                                 "MASK argument", "MINLOC");
 324         }
 325     }
 326
 327   for (n = 0; n < rank; n++)
 328     {
 329       count[n] = 0;
 330       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 331       if (extent[n] <= 0)
 332         return;
 333     }
 334
 335   dest = retarray->data;
 336   base = array->data;
 337
 338   while (base)
 339     {
 340       const GFC_INTEGER_2 * restrict src;
 341       const GFC_LOGICAL_1 * restrict msrc;
 342       GFC_INTEGER_4 result;
 343       src = base;
 344       msrc = mbase;
 345       {
 346
 347         GFC_INTEGER_2 minval;
 348 #if defined (GFC_INTEGER_2_INFINITY)
 349         minval = GFC_INTEGER_2_INFINITY;
 350 #else
 351         minval = GFC_INTEGER_2_HUGE;
 352 #endif
 353 #if defined (GFC_INTEGER_2_QUIET_NAN)
 354         GFC_INTEGER_4 result2 = 0;
 355 #endif
 356         result = 0;
 357         if (len <= 0)
 358           *dest = 0;
 359         else
 360           {
 361             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 362               {
 363
 364                 if (*msrc)
 365                   {
 366 #if defined (GFC_INTEGER_2_QUIET_NAN)
 367                     if (!result2)
 368                       result2 = (GFC_INTEGER_4)n + 1;
 369                     if (*src <= minval)
 370 #endif
 371                       {
 372                         minval = *src;
 373                         result = (GFC_INTEGER_4)n + 1;
 374                         break;
 375                       }
 376                   }
 377               }
 378 #if defined (GFC_INTEGER_2_QUIET_NAN)
 379             if (unlikely (n >= len))
 380               result = result2;
 381             else
 382 #endif
 383             for (; n < len; n++, src += delta, msrc += mdelta)
 384               {
 385                 if (*msrc && *src < minval)
 386                   {
 387                     minval = *src;
 388                     result = (GFC_INTEGER_4)n + 1;
 389                   }
 390               }
 391             *dest = result;
 392           }
 393       }
 394       /* Advance to the next element.  */
 395       count[0]++;
 396       base += sstride[0];
 397       mbase += mstride[0];
 398       dest += dstride[0];
 399       n = 0;
 400       while (count[n] == extent[n])
 401         {
 402           /* When we get to the end of a dimension, reset it and increment
 403              the next dimension.  */
 404           count[n] = 0;
 405           /* We could precalculate these products, but this is a less
 406              frequently used path so probably not worth it.  */
 407           base -= sstride[n] * extent[n];
 408           mbase -= mstride[n] * extent[n];
 409           dest -= dstride[n] * extent[n];
 410           n++;
 411           if (n == rank)
 412             {
 413               /* Break out of the look.  */
 414               base = NULL;
 415               break;
 416             }
 417           else
 418             {
 419               count[n]++;
 420               base += sstride[n];
 421               mbase += mstride[n];
 422               dest += dstride[n];
 423             }
 424         }
 425     }
 426 }
 427
 428
 429 extern void sminloc1_4_i2 (gfc_array_i4 * const restrict,
 430         gfc_array_i2 * const restrict, const index_type * const restrict,
 431         GFC_LOGICAL_4 *);
 432 export_proto(sminloc1_4_i2);
 433
 434 void
 435 sminloc1_4_i2 (gfc_array_i4 * const restrict retarray,
 436         gfc_array_i2 * const restrict array,
 437         const index_type * const restrict pdim,
 438         GFC_LOGICAL_4 * mask)
 439 {
 440   index_type count[GFC_MAX_DIMENSIONS];
 441   index_type extent[GFC_MAX_DIMENSIONS];
 442   index_type dstride[GFC_MAX_DIMENSIONS];
 443   GFC_INTEGER_4 * restrict dest;
 444   index_type rank;
 445   index_type n;
 446   index_type dim;
 447
 448
 449   if (*mask)
 450     {
 451       minloc1_4_i2 (retarray, array, pdim);
 452       return;
 453     }
 454   /* Make dim zero based to avoid confusion.  */
 455   dim = (*pdim) - 1;
 456   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 457
 458   for (n = 0; n < dim; n++)
 459     {
 460       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 461
 462       if (extent[n] <= 0)
 463         extent[n] = 0;
 464     }
 465
 466   for (n = dim; n < rank; n++)
 467     {
 468       extent[n] =
 469         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 470
 471       if (extent[n] <= 0)
 472         extent[n] = 0;
 473     }
 474
 475   if (retarray->data == NULL)
 476     {
 477       size_t alloc_size, str;
 478
 479       for (n = 0; n < rank; n++)
 480         {
 481           if (n == 0)
 482             str = 1;
 483           else
 484             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 485
 486           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 487
 488         }
 489
 490       retarray->offset = 0;
 491       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 492
 493       alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 494                    * extent[rank-1];
 495
 496       if (alloc_size == 0)
 497         {
 498           /* Make sure we have a zero-sized array.  */
 499           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 500           return;
 501         }
 502       else
 503         retarray->data = internal_malloc_size (alloc_size);
 504     }
 505   else
 506     {
 507       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 508         runtime_error ("rank of return array incorrect in"
 509                        " MINLOC intrinsic: is %ld, should be %ld",
 510                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 511                        (long int) rank);
 512
 513       if (unlikely (compile_options.bounds_check))
 514         {
 515           for (n=0; n < rank; n++)
 516             {
 517               index_type ret_extent;
 518
 519               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 520               if (extent[n] != ret_extent)
 521                 runtime_error ("Incorrect extent in return value of"
 522                                " MINLOC intrinsic in dimension %ld:"
 523                                " is %ld, should be %ld", (long int) n + 1,
 524                                (long int) ret_extent, (long int) extent[n]);
 525             }
 526         }
 527     }
 528
 529   for (n = 0; n < rank; n++)
 530     {
 531       count[n] = 0;
 532       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 533     }
 534
 535   dest = retarray->data;
 536
 537   while(1)
 538     {
 539       *dest = 0;
 540       count[0]++;
 541       dest += dstride[0];
 542       n = 0;
 543       while (count[n] == extent[n])
 544         {
 545           /* When we get to the end of a dimension, reset it and increment
 546              the next dimension.  */
 547           count[n] = 0;
 548           /* We could precalculate these products, but this is a less
 549              frequently used path so probably not worth it.  */
 550           dest -= dstride[n] * extent[n];
 551           n++;
 552           if (n == rank)
 553             return;
 554           else
 555             {
 556               count[n]++;
 557               dest += dstride[n];
 558             }
 559         }
 560     }
 561 }
 562
 563 #endif