libgfortran/generated/maxloc1_4_r10.c

   1 /* Implementation of the MAXLOC 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_10) && defined (HAVE_GFC_INTEGER_4)
  38
  39
  40 extern void maxloc1_4_r10 (gfc_array_i4 * const restrict,
  41         gfc_array_r10 * const restrict, const index_type * const restrict);
  42 export_proto(maxloc1_4_r10);
  43
  44 void
  45 maxloc1_4_r10 (gfc_array_i4 * const restrict retarray,
  46         gfc_array_r10 * 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_10 * restrict base;
  54   GFC_INTEGER_4 * restrict dest;
  55   index_type rank;
  56   index_type n;
  57   index_type len;
  58   index_type delta;
  59   index_type dim;
  60
  61   /* Make dim zero based to avoid confusion.  */
  62   dim = (*pdim) - 1;
  63   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  64
  65   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  66   delta = array->dim[dim].stride;
  67
  68   for (n = 0; n < dim; n++)
  69     {
  70       sstride[n] = array->dim[n].stride;
  71       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  72
  73       if (extent[n] < 0)
  74         extent[n] = 0;
  75     }
  76   for (n = dim; n < rank; n++)
  77     {
  78       sstride[n] = array->dim[n + 1].stride;
  79       extent[n] =
  80         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  81
  82       if (extent[n] < 0)
  83         extent[n] = 0;
  84     }
  85
  86   if (retarray->data == NULL)
  87     {
  88       size_t alloc_size;
  89
  90       for (n = 0; n < rank; n++)
  91         {
  92           retarray->dim[n].lbound = 0;
  93           retarray->dim[n].ubound = extent[n]-1;
  94           if (n == 0)
  95             retarray->dim[n].stride = 1;
  96           else
  97             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
  98         }
  99
 100       retarray->offset = 0;
 101       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 102
 103       alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
 104                    * extent[rank-1];
 105
 106       if (alloc_size == 0)
 107         {
 108           /* Make sure we have a zero-sized array.  */
 109           retarray->dim[0].lbound = 0;
 110           retarray->dim[0].ubound = -1;
 111           return;
 112         }
 113       else
 114         retarray->data = internal_malloc_size (alloc_size);
 115     }
 116   else
 117     {
 118       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 119         runtime_error ("rank of return array incorrect in"
 120                        " MAXLOC intrinsic: is %d, should be %d",
 121                        GFC_DESCRIPTOR_RANK (retarray), rank);
 122
 123       if (compile_options.bounds_check)
 124         {
 125           for (n=0; n < rank; n++)
 126             {
 127               index_type ret_extent;
 128
 129               ret_extent = retarray->dim[n].ubound + 1
 130                 - retarray->dim[n].lbound;
 131               if (extent[n] != ret_extent)
 132                 runtime_error ("Incorrect extent in return value of"
 133                                " MAXLOC intrinsic in dimension %d:"
 134                                " is %ld, should be %ld", n + 1,
 135                                (long int) ret_extent, (long int) extent[n]);
 136             }
 137         }
 138     }
 139
 140   for (n = 0; n < rank; n++)
 141     {
 142       count[n] = 0;
 143       dstride[n] = retarray->dim[n].stride;
 144       if (extent[n] <= 0)
 145         len = 0;
 146     }
 147
 148   base = array->data;
 149   dest = retarray->data;
 150
 151   while (base)
 152     {
 153       const GFC_REAL_10 * restrict src;
 154       GFC_INTEGER_4 result;
 155       src = base;
 156       {
 157
 158   GFC_REAL_10 maxval;
 159   maxval = -GFC_REAL_10_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 > maxval || !result)
 169     {
 170       maxval = *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               base = NULL;
 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 mmaxloc1_4_r10 (gfc_array_i4 * const restrict,
 210         gfc_array_r10 * const restrict, const index_type * const restrict,
 211         gfc_array_l1 * const restrict);
 212 export_proto(mmaxloc1_4_r10);
 213
 214 void
 215 mmaxloc1_4_r10 (gfc_array_i4 * const restrict retarray,
 216         gfc_array_r10 * 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_10 * 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 MAXLOC intrinsic");
 315
 316       if (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                                " MAXLOC intrinsic in dimension %d:"
 327                                " is %ld, should be %ld", 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                                " MAXLOC intrinsic in dimension %d:"
 339                                " is %ld, should be %ld", 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_10 * 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_10 maxval;
 366   maxval = -GFC_REAL_10_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 > maxval || !result))
 376     {
 377       maxval = *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 smaxloc1_4_r10 (gfc_array_i4 * const restrict,
 420         gfc_array_r10 * const restrict, const index_type * const restrict,
 421         GFC_LOGICAL_4 *);
 422 export_proto(smaxloc1_4_r10);
 423
 424 void
 425 smaxloc1_4_r10 (gfc_array_i4 * const restrict retarray,
 426         gfc_array_r10 * const restrict array,
 427         const index_type * const restrict pdim,
 428         GFC_LOGICAL_4 * mask)
 429 {
 430   index_type rank;
 431   index_type n;
 432   index_type dstride;
 433   GFC_INTEGER_4 *dest;
 434
 435   if (*mask)
 436     {
 437       maxloc1_4_r10 (retarray, array, pdim);
 438       return;
 439     }
 440     rank = GFC_DESCRIPTOR_RANK (array);
 441   if (rank <= 0)
 442     runtime_error ("Rank of array needs to be > 0");
 443
 444   if (retarray->data == NULL)
 445     {
 446       retarray->dim[0].lbound = 0;
 447       retarray->dim[0].ubound = rank-1;
 448       retarray->dim[0].stride = 1;
 449       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 450       retarray->offset = 0;
 451       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
 452     }
 453   else
 454     {
 455       if (compile_options.bounds_check)
 456         {
 457           int ret_rank;
 458           index_type ret_extent;
 459
 460           ret_rank = GFC_DESCRIPTOR_RANK (retarray);
 461           if (ret_rank != 1)
 462             runtime_error ("rank of return array in MAXLOC intrinsic"
 463                            " should be 1, is %d", ret_rank);
 464
 465           ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
 466             if (ret_extent != rank)
 467               runtime_error ("dimension of return array incorrect");
 468         }
 469     }
 470     dstride = retarray->dim[0].stride;
 471     dest = retarray->data;
 472
 473     for (n = 0; n < rank; n++)
 474       dest[n * dstride] = 0 ;
 475 }
 476
 477 #endif