libgfortran/generated/minloc1_16_r4.c

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