libgfortran/generated/maxloc1_4_i1.c

   1 /* Implementation of the MAXLOC 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_1) && defined (HAVE_GFC_INTEGER_4)
  33
  34
  35 extern void maxloc1_4_i1 (gfc_array_i4 * const restrict,
  36         gfc_array_i1 * const restrict, const index_type * const restrict);
  37 export_proto(maxloc1_4_i1);
  38
  39 void
  40 maxloc1_4_i1 (gfc_array_i4 * const restrict retarray,
  41         gfc_array_i1 * 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_1 * 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                        " MAXLOC 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", "MAXLOC");
 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_1 * restrict src;
 142       GFC_INTEGER_4 result;
 143       src = base;
 144       {
 145
 146   GFC_INTEGER_1 maxval;
 147   maxval = (-GFC_INTEGER_1_HUGE-1);
 148   result = 0;
 149         if (len <= 0)
 150           *dest = 0;
 151         else
 152           {
 153             for (n = 0; n < len; n++, src += delta)
 154               {
 155
 156   if (*src > maxval || !result)
 157     {
 158       maxval = *src;
 159       result = (GFC_INTEGER_4)n + 1;
 160     }
 161           }
 162             *dest = result;
 163           }
 164       }
 165       /* Advance to the next element.  */
 166       count[0]++;
 167       base += sstride[0];
 168       dest += dstride[0];
 169       n = 0;
 170       while (count[n] == extent[n])
 171         {
 172           /* When we get to the end of a dimension, reset it and increment
 173              the next dimension.  */
 174           count[n] = 0;
 175           /* We could precalculate these products, but this is a less
 176              frequently used path so probably not worth it.  */
 177           base -= sstride[n] * extent[n];
 178           dest -= dstride[n] * extent[n];
 179           n++;
 180           if (n == rank)
 181             {
 182               /* Break out of the look.  */
 183               continue_loop = 0;
 184               break;
 185             }
 186           else
 187             {
 188               count[n]++;
 189               base += sstride[n];
 190               dest += dstride[n];
 191             }
 192         }
 193     }
 194 }
 195
 196
 197 extern void mmaxloc1_4_i1 (gfc_array_i4 * const restrict,
 198         gfc_array_i1 * const restrict, const index_type * const restrict,
 199         gfc_array_l1 * const restrict);
 200 export_proto(mmaxloc1_4_i1);
 201
 202 void
 203 mmaxloc1_4_i1 (gfc_array_i4 * const restrict retarray,
 204         gfc_array_i1 * const restrict array,
 205         const index_type * const restrict pdim,
 206         gfc_array_l1 * const restrict mask)
 207 {
 208   index_type count[GFC_MAX_DIMENSIONS];
 209   index_type extent[GFC_MAX_DIMENSIONS];
 210   index_type sstride[GFC_MAX_DIMENSIONS];
 211   index_type dstride[GFC_MAX_DIMENSIONS];
 212   index_type mstride[GFC_MAX_DIMENSIONS];
 213   GFC_INTEGER_4 * restrict dest;
 214   const GFC_INTEGER_1 * restrict base;
 215   const GFC_LOGICAL_1 * restrict mbase;
 216   int rank;
 217   int dim;
 218   index_type n;
 219   index_type len;
 220   index_type delta;
 221   index_type mdelta;
 222   int mask_kind;
 223
 224   dim = (*pdim) - 1;
 225   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 226
 227   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 228   if (len <= 0)
 229     return;
 230
 231   mbase = mask->data;
 232
 233   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 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   delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 245   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 246
 247   for (n = 0; n < dim; n++)
 248     {
 249       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 250       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 251       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 252
 253       if (extent[n] < 0)
 254         extent[n] = 0;
 255
 256     }
 257   for (n = dim; n < rank; n++)
 258     {
 259       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 260       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 261       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 262
 263       if (extent[n] < 0)
 264         extent[n] = 0;
 265     }
 266
 267   if (retarray->data == NULL)
 268     {
 269       size_t alloc_size, str;
 270
 271       for (n = 0; n < rank; n++)
 272         {
 273           if (n == 0)
 274             str = 1;
 275           else
 276             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 277
 278           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 279
 280         }
 281
 282       alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 283                    * extent[rank-1];
 284
 285       retarray->offset = 0;
 286       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 287
 288       if (alloc_size == 0)
 289         {
 290           /* Make sure we have a zero-sized array.  */
 291           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 292           return;
 293         }
 294       else
 295         retarray->data = internal_malloc_size (alloc_size);
 296
 297     }
 298   else
 299     {
 300       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 301         runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
 302
 303       if (unlikely (compile_options.bounds_check))
 304         {
 305           bounds_ifunction_return ((array_t *) retarray, extent,
 306                                    "return value", "MAXLOC");
 307           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 308                                 "MASK argument", "MAXLOC");
 309         }
 310     }
 311
 312   for (n = 0; n < rank; n++)
 313     {
 314       count[n] = 0;
 315       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 316       if (extent[n] <= 0)
 317         return;
 318     }
 319
 320   dest = retarray->data;
 321   base = array->data;
 322
 323   while (base)
 324     {
 325       const GFC_INTEGER_1 * restrict src;
 326       const GFC_LOGICAL_1 * restrict msrc;
 327       GFC_INTEGER_4 result;
 328       src = base;
 329       msrc = mbase;
 330       {
 331
 332   GFC_INTEGER_1 maxval;
 333   maxval = (-GFC_INTEGER_1_HUGE-1);
 334   result = 0;
 335         if (len <= 0)
 336           *dest = 0;
 337         else
 338           {
 339             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 340               {
 341
 342   if (*msrc && (*src > maxval || !result))
 343     {
 344       maxval = *src;
 345       result = (GFC_INTEGER_4)n + 1;
 346     }
 347               }
 348             *dest = result;
 349           }
 350       }
 351       /* Advance to the next element.  */
 352       count[0]++;
 353       base += sstride[0];
 354       mbase += mstride[0];
 355       dest += dstride[0];
 356       n = 0;
 357       while (count[n] == extent[n])
 358         {
 359           /* When we get to the end of a dimension, reset it and increment
 360              the next dimension.  */
 361           count[n] = 0;
 362           /* We could precalculate these products, but this is a less
 363              frequently used path so probably not worth it.  */
 364           base -= sstride[n] * extent[n];
 365           mbase -= mstride[n] * extent[n];
 366           dest -= dstride[n] * extent[n];
 367           n++;
 368           if (n == rank)
 369             {
 370               /* Break out of the look.  */
 371               base = NULL;
 372               break;
 373             }
 374           else
 375             {
 376               count[n]++;
 377               base += sstride[n];
 378               mbase += mstride[n];
 379               dest += dstride[n];
 380             }
 381         }
 382     }
 383 }
 384
 385
 386 extern void smaxloc1_4_i1 (gfc_array_i4 * const restrict,
 387         gfc_array_i1 * const restrict, const index_type * const restrict,
 388         GFC_LOGICAL_4 *);
 389 export_proto(smaxloc1_4_i1);
 390
 391 void
 392 smaxloc1_4_i1 (gfc_array_i4 * const restrict retarray,
 393         gfc_array_i1 * const restrict array,
 394         const index_type * const restrict pdim,
 395         GFC_LOGICAL_4 * mask)
 396 {
 397   index_type count[GFC_MAX_DIMENSIONS];
 398   index_type extent[GFC_MAX_DIMENSIONS];
 399   index_type sstride[GFC_MAX_DIMENSIONS];
 400   index_type dstride[GFC_MAX_DIMENSIONS];
 401   GFC_INTEGER_4 * restrict dest;
 402   index_type rank;
 403   index_type n;
 404   index_type dim;
 405
 406
 407   if (*mask)
 408     {
 409       maxloc1_4_i1 (retarray, array, pdim);
 410       return;
 411     }
 412   /* Make dim zero based to avoid confusion.  */
 413   dim = (*pdim) - 1;
 414   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 415
 416   for (n = 0; n < dim; n++)
 417     {
 418       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 419       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 420
 421       if (extent[n] <= 0)
 422         extent[n] = 0;
 423     }
 424
 425   for (n = dim; n < rank; n++)
 426     {
 427       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
 428       extent[n] =
 429         GFC_DESCRIPTOR_EXTENT(array,n + 1);
 430
 431       if (extent[n] <= 0)
 432         extent[n] = 0;
 433     }
 434
 435   if (retarray->data == NULL)
 436     {
 437       size_t alloc_size, str;
 438
 439       for (n = 0; n < rank; n++)
 440         {
 441           if (n == 0)
 442             str = 1;
 443           else
 444             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 445
 446           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 447
 448         }
 449
 450       retarray->offset = 0;
 451       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 452
 453       alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
 454                    * extent[rank-1];
 455
 456       if (alloc_size == 0)
 457         {
 458           /* Make sure we have a zero-sized array.  */
 459           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 460           return;
 461         }
 462       else
 463         retarray->data = internal_malloc_size (alloc_size);
 464     }
 465   else
 466     {
 467       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 468         runtime_error ("rank of return array incorrect in"
 469                        " MAXLOC intrinsic: is %ld, should be %ld",
 470                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 471                        (long int) rank);
 472
 473       if (unlikely (compile_options.bounds_check))
 474         {
 475           for (n=0; n < rank; n++)
 476             {
 477               index_type ret_extent;
 478
 479               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 480               if (extent[n] != ret_extent)
 481                 runtime_error ("Incorrect extent in return value of"
 482                                " MAXLOC intrinsic in dimension %ld:"
 483                                " is %ld, should be %ld", (long int) n + 1,
 484                                (long int) ret_extent, (long int) extent[n]);
 485             }
 486         }
 487     }
 488
 489   for (n = 0; n < rank; n++)
 490     {
 491       count[n] = 0;
 492       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 493     }
 494
 495   dest = retarray->data;
 496
 497   while(1)
 498     {
 499       *dest = 0;
 500       count[0]++;
 501       dest += dstride[0];
 502       n = 0;
 503       while (count[n] == extent[n])
 504         {
 505           /* When we get to the end of a dimension, reset it and increment
 506              the next dimension.  */
 507           count[n] = 0;
 508           /* We could precalculate these products, but this is a less
 509              frequently used path so probably not worth it.  */
 510           dest -= dstride[n] * extent[n];
 511           n++;
 512           if (n == rank)
 513             return;
 514           else
 515             {
 516               count[n]++;
 517               dest += dstride[n];
 518             }
 519         }
 520     }
 521 }
 522
 523 #endif