libgfortran/generated/minloc1_4_r16.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_16) && defined (HAVE_GFC_INTEGER_4)
  38
  39
  40 extern void minloc1_4_r16 (gfc_array_i4 * const restrict,
  41         gfc_array_r16 * const restrict, const index_type * const restrict);
  42 export_proto(minloc1_4_r16);
  43
  44 void
  45 minloc1_4_r16 (gfc_array_i4 * const restrict retarray,
  46         gfc_array_r16 * 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_16 * 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                        " MINLOC intrinsic: is %ld, should be %ld",
 121                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 122                        (long int) rank);
 123
 124       if (compile_options.bounds_check)
 125         {
 126           for (n=0; n < rank; n++)
 127             {
 128               index_type ret_extent;
 129
 130               ret_extent = retarray->dim[n].ubound + 1
 131                 - retarray->dim[n].lbound;
 132               if (extent[n] != ret_extent)
 133                 runtime_error ("Incorrect extent in return value of"
 134                                " MINLOC intrinsic in dimension %ld:"
 135                                " is %ld, should be %ld", (long int) n + 1,
 136                                (long int) ret_extent, (long int) extent[n]);
 137             }
 138         }
 139     }
 140
 141   for (n = 0; n < rank; n++)
 142     {
 143       count[n] = 0;
 144       dstride[n] = retarray->dim[n].stride;
 145       if (extent[n] <= 0)
 146         len = 0;
 147     }
 148
 149   base = array->data;
 150   dest = retarray->data;
 151
 152   while (base)
 153     {
 154       const GFC_REAL_16 * restrict src;
 155       GFC_INTEGER_4 result;
 156       src = base;
 157       {
 158
 159   GFC_REAL_16 minval;
 160   minval = GFC_REAL_16_HUGE;
 161   result = 0;
 162         if (len <= 0)
 163           *dest = 0;
 164         else
 165           {
 166             for (n = 0; n < len; n++, src += delta)
 167               {
 168
 169   if (*src < minval || !result)
 170     {
 171       minval = *src;
 172       result = (GFC_INTEGER_4)n + 1;
 173     }
 174           }
 175             *dest = result;
 176           }
 177       }
 178       /* Advance to the next element.  */
 179       count[0]++;
 180       base += sstride[0];
 181       dest += dstride[0];
 182       n = 0;
 183       while (count[n] == extent[n])
 184         {
 185           /* When we get to the end of a dimension, reset it and increment
 186              the next dimension.  */
 187           count[n] = 0;
 188           /* We could precalculate these products, but this is a less
 189              frequently used path so probably not worth it.  */
 190           base -= sstride[n] * extent[n];
 191           dest -= dstride[n] * extent[n];
 192           n++;
 193           if (n == rank)
 194             {
 195               /* Break out of the look.  */
 196               base = NULL;
 197               break;
 198             }
 199           else
 200             {
 201               count[n]++;
 202               base += sstride[n];
 203               dest += dstride[n];
 204             }
 205         }
 206     }
 207 }
 208
 209
 210 extern void mminloc1_4_r16 (gfc_array_i4 * const restrict,
 211         gfc_array_r16 * const restrict, const index_type * const restrict,
 212         gfc_array_l1 * const restrict);
 213 export_proto(mminloc1_4_r16);
 214
 215 void
 216 mminloc1_4_r16 (gfc_array_i4 * const restrict retarray,
 217         gfc_array_r16 * const restrict array,
 218         const index_type * const restrict pdim,
 219         gfc_array_l1 * const restrict mask)
 220 {
 221   index_type count[GFC_MAX_DIMENSIONS];
 222   index_type extent[GFC_MAX_DIMENSIONS];
 223   index_type sstride[GFC_MAX_DIMENSIONS];
 224   index_type dstride[GFC_MAX_DIMENSIONS];
 225   index_type mstride[GFC_MAX_DIMENSIONS];
 226   GFC_INTEGER_4 * restrict dest;
 227   const GFC_REAL_16 * restrict base;
 228   const GFC_LOGICAL_1 * restrict mbase;
 229   int rank;
 230   int dim;
 231   index_type n;
 232   index_type len;
 233   index_type delta;
 234   index_type mdelta;
 235   int mask_kind;
 236
 237   dim = (*pdim) - 1;
 238   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 239
 240   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 241   if (len <= 0)
 242     return;
 243
 244   mbase = mask->data;
 245
 246   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 247
 248   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 249 #ifdef HAVE_GFC_LOGICAL_16
 250       || mask_kind == 16
 251 #endif
 252       )
 253     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 254   else
 255     runtime_error ("Funny sized logical array");
 256
 257   delta = array->dim[dim].stride;
 258   mdelta = mask->dim[dim].stride * mask_kind;
 259
 260   for (n = 0; n < dim; n++)
 261     {
 262       sstride[n] = array->dim[n].stride;
 263       mstride[n] = mask->dim[n].stride * mask_kind;
 264       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 265
 266       if (extent[n] < 0)
 267         extent[n] = 0;
 268
 269     }
 270   for (n = dim; n < rank; n++)
 271     {
 272       sstride[n] = array->dim[n + 1].stride;
 273       mstride[n] = mask->dim[n + 1].stride * mask_kind;
 274       extent[n] =
 275         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 276
 277       if (extent[n] < 0)
 278         extent[n] = 0;
 279     }
 280
 281   if (retarray->data == NULL)
 282     {
 283       size_t alloc_size;
 284
 285       for (n = 0; n < rank; n++)
 286         {
 287           retarray->dim[n].lbound = 0;
 288           retarray->dim[n].ubound = extent[n]-1;
 289           if (n == 0)
 290             retarray->dim[n].stride = 1;
 291           else
 292             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 293         }
 294
 295       alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
 296                    * extent[rank-1];
 297
 298       retarray->offset = 0;
 299       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 300
 301       if (alloc_size == 0)
 302         {
 303           /* Make sure we have a zero-sized array.  */
 304           retarray->dim[0].lbound = 0;
 305           retarray->dim[0].ubound = -1;
 306           return;
 307         }
 308       else
 309         retarray->data = internal_malloc_size (alloc_size);
 310
 311     }
 312   else
 313     {
 314       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 315         runtime_error ("rank of return array incorrect in MINLOC intrinsic");
 316
 317       if (compile_options.bounds_check)
 318         {
 319           for (n=0; n < rank; n++)
 320             {
 321               index_type ret_extent;
 322
 323               ret_extent = retarray->dim[n].ubound + 1
 324                 - retarray->dim[n].lbound;
 325               if (extent[n] != ret_extent)
 326                 runtime_error ("Incorrect extent in return value of"
 327                                " MINLOC intrinsic in dimension %ld:"
 328                                " is %ld, should be %ld", (long int) n + 1,
 329                                (long int) ret_extent, (long int) extent[n]);
 330             }
 331           for (n=0; n<= rank; n++)
 332             {
 333               index_type mask_extent, array_extent;
 334
 335               array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
 336               mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
 337               if (array_extent != mask_extent)
 338                 runtime_error ("Incorrect extent in MASK argument of"
 339                                " MINLOC intrinsic in dimension %ld:"
 340                                " is %ld, should be %ld", (long int) n + 1,
 341                                (long int) mask_extent, (long int) array_extent);
 342             }
 343         }
 344     }
 345
 346   for (n = 0; n < rank; n++)
 347     {
 348       count[n] = 0;
 349       dstride[n] = retarray->dim[n].stride;
 350       if (extent[n] <= 0)
 351         return;
 352     }
 353
 354   dest = retarray->data;
 355   base = array->data;
 356
 357   while (base)
 358     {
 359       const GFC_REAL_16 * restrict src;
 360       const GFC_LOGICAL_1 * restrict msrc;
 361       GFC_INTEGER_4 result;
 362       src = base;
 363       msrc = mbase;
 364       {
 365
 366   GFC_REAL_16 minval;
 367   minval = GFC_REAL_16_HUGE;
 368   result = 0;
 369         if (len <= 0)
 370           *dest = 0;
 371         else
 372           {
 373             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 374               {
 375
 376   if (*msrc && (*src < minval || !result))
 377     {
 378       minval = *src;
 379       result = (GFC_INTEGER_4)n + 1;
 380     }
 381               }
 382             *dest = result;
 383           }
 384       }
 385       /* Advance to the next element.  */
 386       count[0]++;
 387       base += sstride[0];
 388       mbase += mstride[0];
 389       dest += dstride[0];
 390       n = 0;
 391       while (count[n] == extent[n])
 392         {
 393           /* When we get to the end of a dimension, reset it and increment
 394              the next dimension.  */
 395           count[n] = 0;
 396           /* We could precalculate these products, but this is a less
 397              frequently used path so probably not worth it.  */
 398           base -= sstride[n] * extent[n];
 399           mbase -= mstride[n] * extent[n];
 400           dest -= dstride[n] * extent[n];
 401           n++;
 402           if (n == rank)
 403             {
 404               /* Break out of the look.  */
 405               base = NULL;
 406               break;
 407             }
 408           else
 409             {
 410               count[n]++;
 411               base += sstride[n];
 412               mbase += mstride[n];
 413               dest += dstride[n];
 414             }
 415         }
 416     }
 417 }
 418
 419
 420 extern void sminloc1_4_r16 (gfc_array_i4 * const restrict,
 421         gfc_array_r16 * const restrict, const index_type * const restrict,
 422         GFC_LOGICAL_4 *);
 423 export_proto(sminloc1_4_r16);
 424
 425 void
 426 sminloc1_4_r16 (gfc_array_i4 * const restrict retarray,
 427         gfc_array_r16 * const restrict array,
 428         const index_type * const restrict pdim,
 429         GFC_LOGICAL_4 * mask)
 430 {
 431   index_type rank;
 432   index_type n;
 433   index_type dstride;
 434   GFC_INTEGER_4 *dest;
 435
 436   if (*mask)
 437     {
 438       minloc1_4_r16 (retarray, array, pdim);
 439       return;
 440     }
 441     rank = GFC_DESCRIPTOR_RANK (array);
 442   if (rank <= 0)
 443     runtime_error ("Rank of array needs to be > 0");
 444
 445   if (retarray->data == NULL)
 446     {
 447       retarray->dim[0].lbound = 0;
 448       retarray->dim[0].ubound = rank-1;
 449       retarray->dim[0].stride = 1;
 450       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 451       retarray->offset = 0;
 452       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
 453     }
 454   else
 455     {
 456       if (compile_options.bounds_check)
 457         {
 458           int ret_rank;
 459           index_type ret_extent;
 460
 461           ret_rank = GFC_DESCRIPTOR_RANK (retarray);
 462           if (ret_rank != 1)
 463             runtime_error ("rank of return array in MINLOC intrinsic"
 464                            " should be 1, is %ld", (long int) ret_rank);
 465
 466           ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
 467             if (ret_extent != rank)
 468               runtime_error ("dimension of return array incorrect");
 469         }
 470     }
 471     dstride = retarray->dim[0].stride;
 472     dest = retarray->data;
 473
 474     for (n = 0; n < rank; n++)
 475       dest[n * dstride] = 0 ;
 476 }
 477
 478 #endif