libgfortran/generated/maxloc0_16_r16.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_REAL_16) && defined (HAVE_GFC_INTEGER_16)
  33
  34
  35 extern void maxloc0_16_r16 (gfc_array_i16 * const restrict retarray,
  36         gfc_array_r16 * const restrict array);
  37 export_proto(maxloc0_16_r16);
  38
  39 void
  40 maxloc0_16_r16 (gfc_array_i16 * const restrict retarray,
  41         gfc_array_r16 * const restrict array)
  42 {
  43   index_type count[GFC_MAX_DIMENSIONS];
  44   index_type extent[GFC_MAX_DIMENSIONS];
  45   index_type sstride[GFC_MAX_DIMENSIONS];
  46   index_type dstride;
  47   const GFC_REAL_16 *base;
  48   GFC_INTEGER_16 * restrict dest;
  49   index_type rank;
  50   index_type n;
  51
  52   rank = GFC_DESCRIPTOR_RANK (array);
  53   if (rank <= 0)
  54     runtime_error ("Rank of array needs to be > 0");
  55
  56   if (retarray->data == NULL)
  57     {
  58       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
  59       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
  60       retarray->offset = 0;
  61       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
  62     }
  63   else
  64     {
  65       if (unlikely (compile_options.bounds_check))
  66         {
  67           int ret_rank;
  68           index_type ret_extent;
  69
  70           ret_rank = GFC_DESCRIPTOR_RANK (retarray);
  71           if (ret_rank != 1)
  72             runtime_error ("rank of return array in MAXLOC intrinsic"
  73                            " should be 1, is %ld", (long int) ret_rank);
  74
  75           ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
  76           if (ret_extent != rank)
  77             runtime_error ("Incorrect extent in return value of"
  78                            " MAXLOC intrnisic: is %ld, should be %ld",
  79                            (long int) ret_extent, (long int) rank);
  80         }
  81     }
  82
  83   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  84   dest = retarray->data;
  85   for (n = 0; n < rank; n++)
  86     {
  87       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  88       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  89       count[n] = 0;
  90       if (extent[n] <= 0)
  91         {
  92           /* Set the return value.  */
  93           for (n = 0; n < rank; n++)
  94             dest[n * dstride] = 0;
  95           return;
  96         }
  97     }
  98
  99   base = array->data;
 100
 101   /* Initialize the return value.  */
 102   for (n = 0; n < rank; n++)
 103     dest[n * dstride] = 0;
 104   {
 105
 106   GFC_REAL_16 maxval;
 107
 108   maxval = -GFC_REAL_16_HUGE;
 109
 110   while (base)
 111     {
 112       {
 113         /* Implementation start.  */
 114
 115   if (*base > maxval || !dest[0])
 116     {
 117       maxval = *base;
 118       for (n = 0; n < rank; n++)
 119         dest[n * dstride] = count[n] + 1;
 120     }
 121         /* Implementation end.  */
 122       }
 123       /* Advance to the next element.  */
 124       count[0]++;
 125       base += sstride[0];
 126       n = 0;
 127       while (count[n] == extent[n])
 128         {
 129           /* When we get to the end of a dimension, reset it and increment
 130              the next dimension.  */
 131           count[n] = 0;
 132           /* We could precalculate these products, but this is a less
 133              frequently used path so probably not worth it.  */
 134           base -= sstride[n] * extent[n];
 135           n++;
 136           if (n == rank)
 137             {
 138               /* Break out of the loop.  */
 139               base = NULL;
 140               break;
 141             }
 142           else
 143             {
 144               count[n]++;
 145               base += sstride[n];
 146             }
 147         }
 148     }
 149   }
 150 }
 151
 152
 153 extern void mmaxloc0_16_r16 (gfc_array_i16 * const restrict,
 154         gfc_array_r16 * const restrict, gfc_array_l1 * const restrict);
 155 export_proto(mmaxloc0_16_r16);
 156
 157 void
 158 mmaxloc0_16_r16 (gfc_array_i16 * const restrict retarray,
 159         gfc_array_r16 * const restrict array,
 160         gfc_array_l1 * const restrict mask)
 161 {
 162   index_type count[GFC_MAX_DIMENSIONS];
 163   index_type extent[GFC_MAX_DIMENSIONS];
 164   index_type sstride[GFC_MAX_DIMENSIONS];
 165   index_type mstride[GFC_MAX_DIMENSIONS];
 166   index_type dstride;
 167   GFC_INTEGER_16 *dest;
 168   const GFC_REAL_16 *base;
 169   GFC_LOGICAL_1 *mbase;
 170   int rank;
 171   index_type n;
 172   int mask_kind;
 173
 174   rank = GFC_DESCRIPTOR_RANK (array);
 175   if (rank <= 0)
 176     runtime_error ("Rank of array needs to be > 0");
 177
 178   if (retarray->data == NULL)
 179     {
 180       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
 181       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 182       retarray->offset = 0;
 183       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
 184     }
 185   else
 186     {
 187       if (unlikely (compile_options.bounds_check))
 188         {
 189           int ret_rank, mask_rank;
 190           index_type ret_extent;
 191           int n;
 192           index_type array_extent, mask_extent;
 193
 194           ret_rank = GFC_DESCRIPTOR_RANK (retarray);
 195           if (ret_rank != 1)
 196             runtime_error ("rank of return array in MAXLOC intrinsic"
 197                            " should be 1, is %ld", (long int) ret_rank);
 198
 199           ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
 200           if (ret_extent != rank)
 201             runtime_error ("Incorrect extent in return value of"
 202                            " MAXLOC intrnisic: is %ld, should be %ld",
 203                            (long int) ret_extent, (long int) rank);
 204
 205           mask_rank = GFC_DESCRIPTOR_RANK (mask);
 206           if (rank != mask_rank)
 207             runtime_error ("rank of MASK argument in MAXLOC intrnisic"
 208                            "should be %ld, is %ld", (long int) rank,
 209                            (long int) mask_rank);
 210
 211           for (n=0; n<rank; n++)
 212             {
 213               array_extent = GFC_DESCRIPTOR_EXTENT(array,n);
 214               mask_extent = GFC_DESCRIPTOR_EXTENT(mask,n);
 215               if (array_extent != mask_extent)
 216                 runtime_error ("Incorrect extent in MASK argument of"
 217                                " MAXLOC intrinsic in dimension %ld:"
 218                                " is %ld, should be %ld", (long int) n + 1,
 219                                (long int) mask_extent, (long int) array_extent);
 220             }
 221         }
 222     }
 223
 224   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 225
 226   mbase = mask->data;
 227
 228   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 229 #ifdef HAVE_GFC_LOGICAL_16
 230       || mask_kind == 16
 231 #endif
 232       )
 233     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 234   else
 235     runtime_error ("Funny sized logical array");
 236
 237   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 238   dest = retarray->data;
 239   for (n = 0; n < rank; n++)
 240     {
 241       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 242       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 243       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 244       count[n] = 0;
 245       if (extent[n] <= 0)
 246         {
 247           /* Set the return value.  */
 248           for (n = 0; n < rank; n++)
 249             dest[n * dstride] = 0;
 250           return;
 251         }
 252     }
 253
 254   base = array->data;
 255
 256   /* Initialize the return value.  */
 257   for (n = 0; n < rank; n++)
 258     dest[n * dstride] = 0;
 259   {
 260
 261   GFC_REAL_16 maxval;
 262
 263   maxval = -GFC_REAL_16_HUGE;
 264
 265   while (base)
 266     {
 267       {
 268         /* Implementation start.  */
 269
 270   if (*mbase && (*base > maxval || !dest[0]))
 271     {
 272       maxval = *base;
 273       for (n = 0; n < rank; n++)
 274         dest[n * dstride] = count[n] + 1;
 275     }
 276         /* Implementation end.  */
 277       }
 278       /* Advance to the next element.  */
 279       count[0]++;
 280       base += sstride[0];
 281       mbase += mstride[0];
 282       n = 0;
 283       while (count[n] == extent[n])
 284         {
 285           /* When we get to the end of a dimension, reset it and increment
 286              the next dimension.  */
 287           count[n] = 0;
 288           /* We could precalculate these products, but this is a less
 289              frequently used path so probably not worth it.  */
 290           base -= sstride[n] * extent[n];
 291           mbase -= mstride[n] * extent[n];
 292           n++;
 293           if (n == rank)
 294             {
 295               /* Break out of the loop.  */
 296               base = NULL;
 297               break;
 298             }
 299           else
 300             {
 301               count[n]++;
 302               base += sstride[n];
 303               mbase += mstride[n];
 304             }
 305         }
 306     }
 307   }
 308 }
 309
 310
 311 extern void smaxloc0_16_r16 (gfc_array_i16 * const restrict,
 312         gfc_array_r16 * const restrict, GFC_LOGICAL_4 *);
 313 export_proto(smaxloc0_16_r16);
 314
 315 void
 316 smaxloc0_16_r16 (gfc_array_i16 * const restrict retarray,
 317         gfc_array_r16 * const restrict array,
 318         GFC_LOGICAL_4 * mask)
 319 {
 320   index_type rank;
 321   index_type dstride;
 322   index_type n;
 323   GFC_INTEGER_16 *dest;
 324
 325   if (*mask)
 326     {
 327       maxloc0_16_r16 (retarray, array);
 328       return;
 329     }
 330
 331   rank = GFC_DESCRIPTOR_RANK (array);
 332
 333   if (rank <= 0)
 334     runtime_error ("Rank of array needs to be > 0");
 335
 336   if (retarray->data == NULL)
 337     {
 338       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 339       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 340       retarray->offset = 0;
 341       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
 342     }
 343   else
 344     {
 345       if (unlikely (compile_options.bounds_check))
 346         {
 347           int ret_rank;
 348           index_type ret_extent;
 349
 350           ret_rank = GFC_DESCRIPTOR_RANK (retarray);
 351           if (ret_rank != 1)
 352             runtime_error ("rank of return array in MAXLOC intrinsic"
 353                            " should be 1, is %ld", (long int) ret_rank);
 354
 355           ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
 356             if (ret_extent != rank)
 357               runtime_error ("dimension of return array incorrect");
 358         }
 359     }
 360
 361   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 362   dest = retarray->data;
 363   for (n = 0; n<rank; n++)
 364     dest[n * dstride] = 0 ;
 365 }
 366 #endif