libgfortran/generated/maxloc1_8_r4.c

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