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