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