libgfortran/generated/maxloc0_8_r16.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_16) && defined (HAVE_GFC_INTEGER_8)
  40
  41
  42 extern void maxloc0_8_r16 (gfc_array_i8 * const restrict retarray,
  43         gfc_array_r16 * const restrict array);
  44 export_proto(maxloc0_8_r16);
  45
  46 void
  47 maxloc0_8_r16 (gfc_array_i8 * const restrict retarray,
  48         gfc_array_r16 * const restrict array)
  49 {
  50   index_type count[GFC_MAX_DIMENSIONS];
  51   index_type extent[GFC_MAX_DIMENSIONS];
  52   index_type sstride[GFC_MAX_DIMENSIONS];
  53   index_type dstride;
  54   const GFC_REAL_16 *base;
  55   GFC_INTEGER_8 *dest;
  56   index_type rank;
  57   index_type n;
  58
  59   rank = GFC_DESCRIPTOR_RANK (array);
  60   if (rank <= 0)
  61     runtime_error ("Rank of array needs to be > 0");
  62
  63   if (retarray->data == NULL)
  64     {
  65       retarray->dim[0].lbound = 0;
  66       retarray->dim[0].ubound = rank-1;
  67       retarray->dim[0].stride = 1;
  68       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
  69       retarray->offset = 0;
  70       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank);
  71     }
  72   else
  73     {
  74       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
  75         runtime_error ("rank of return array does not equal 1");
  76
  77       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
  78         runtime_error ("dimension of return array incorrect");
  79     }
  80
  81   dstride = retarray->dim[0].stride;
  82   dest = retarray->data;
  83   for (n = 0; n < rank; n++)
  84     {
  85       sstride[n] = array->dim[n].stride;
  86       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  87       count[n] = 0;
  88       if (extent[n] <= 0)
  89         {
  90           /* Set the return value.  */
  91           for (n = 0; n < rank; n++)
  92             dest[n * dstride] = 0;
  93           return;
  94         }
  95     }
  96
  97   base = array->data;
  98
  99   /* Initialize the return value.  */
 100   for (n = 0; n < rank; n++)
 101     dest[n * dstride] = 0;
 102   {
 103
 104   GFC_REAL_16 maxval;
 105
 106   maxval = -GFC_REAL_16_HUGE;
 107
 108   while (base)
 109     {
 110       {
 111         /* Implementation start.  */
 112
 113   if (*base > maxval || !dest[0])
 114     {
 115       maxval = *base;
 116       for (n = 0; n < rank; n++)
 117         dest[n * dstride] = count[n] + 1;
 118     }
 119         /* Implementation end.  */
 120       }
 121       /* Advance to the next element.  */
 122       count[0]++;
 123       base += sstride[0];
 124       n = 0;
 125       while (count[n] == extent[n])
 126         {
 127           /* When we get to the end of a dimension, reset it and increment
 128              the next dimension.  */
 129           count[n] = 0;
 130           /* We could precalculate these products, but this is a less
 131              frequently used path so probably not worth it.  */
 132           base -= sstride[n] * extent[n];
 133           n++;
 134           if (n == rank)
 135             {
 136               /* Break out of the loop.  */
 137               base = NULL;
 138               break;
 139             }
 140           else
 141             {
 142               count[n]++;
 143               base += sstride[n];
 144             }
 145         }
 146     }
 147   }
 148 }
 149
 150
 151 extern void mmaxloc0_8_r16 (gfc_array_i8 * const restrict,
 152         gfc_array_r16 * const restrict, gfc_array_l4 * const restrict);
 153 export_proto(mmaxloc0_8_r16);
 154
 155 void
 156 mmaxloc0_8_r16 (gfc_array_i8 * const restrict retarray,
 157         gfc_array_r16 * const restrict array,
 158         gfc_array_l4 * const restrict mask)
 159 {
 160   index_type count[GFC_MAX_DIMENSIONS];
 161   index_type extent[GFC_MAX_DIMENSIONS];
 162   index_type sstride[GFC_MAX_DIMENSIONS];
 163   index_type mstride[GFC_MAX_DIMENSIONS];
 164   index_type dstride;
 165   GFC_INTEGER_8 *dest;
 166   const GFC_REAL_16 *base;
 167   GFC_LOGICAL_4 *mbase;
 168   int rank;
 169   index_type n;
 170
 171   rank = GFC_DESCRIPTOR_RANK (array);
 172   if (rank <= 0)
 173     runtime_error ("Rank of array needs to be > 0");
 174
 175   if (retarray->data == NULL)
 176     {
 177       retarray->dim[0].lbound = 0;
 178       retarray->dim[0].ubound = rank-1;
 179       retarray->dim[0].stride = 1;
 180       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 181       retarray->offset = 0;
 182       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank);
 183     }
 184   else
 185     {
 186       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 187         runtime_error ("rank of return array does not equal 1");
 188
 189       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 190         runtime_error ("dimension of return array incorrect");
 191     }
 192
 193   dstride = retarray->dim[0].stride;
 194   dest = retarray->data;
 195   for (n = 0; n < rank; n++)
 196     {
 197       sstride[n] = array->dim[n].stride;
 198       mstride[n] = mask->dim[n].stride;
 199       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 200       count[n] = 0;
 201       if (extent[n] <= 0)
 202         {
 203           /* Set the return value.  */
 204           for (n = 0; n < rank; n++)
 205             dest[n * dstride] = 0;
 206           return;
 207         }
 208     }
 209
 210   base = array->data;
 211   mbase = mask->data;
 212
 213   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 214     {
 215       /* This allows the same loop to be used for all logical types.  */
 216       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 217       for (n = 0; n < rank; n++)
 218         mstride[n] <<= 1;
 219       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 220     }
 221
 222
 223   /* Initialize the return value.  */
 224   for (n = 0; n < rank; n++)
 225     dest[n * dstride] = 0;
 226   {
 227
 228   GFC_REAL_16 maxval;
 229
 230   maxval = -GFC_REAL_16_HUGE;
 231
 232   while (base)
 233     {
 234       {
 235         /* Implementation start.  */
 236
 237   if (*mbase && (*base > maxval || !dest[0]))
 238     {
 239       maxval = *base;
 240       for (n = 0; n < rank; n++)
 241         dest[n * dstride] = count[n] + 1;
 242     }
 243         /* Implementation end.  */
 244       }
 245       /* Advance to the next element.  */
 246       count[0]++;
 247       base += sstride[0];
 248       mbase += mstride[0];
 249       n = 0;
 250       while (count[n] == extent[n])
 251         {
 252           /* When we get to the end of a dimension, reset it and increment
 253              the next dimension.  */
 254           count[n] = 0;
 255           /* We could precalculate these products, but this is a less
 256              frequently used path so probably not worth it.  */
 257           base -= sstride[n] * extent[n];
 258           mbase -= mstride[n] * extent[n];
 259           n++;
 260           if (n == rank)
 261             {
 262               /* Break out of the loop.  */
 263               base = NULL;
 264               break;
 265             }
 266           else
 267             {
 268               count[n]++;
 269               base += sstride[n];
 270               mbase += mstride[n];
 271             }
 272         }
 273     }
 274   }
 275 }
 276
 277
 278 extern void smaxloc0_8_r16 (gfc_array_i8 * const restrict,
 279         gfc_array_r16 * const restrict, GFC_LOGICAL_4 *);
 280 export_proto(smaxloc0_8_r16);
 281
 282 void
 283 smaxloc0_8_r16 (gfc_array_i8 * const restrict retarray,
 284         gfc_array_r16 * const restrict array,
 285         GFC_LOGICAL_4 * mask)
 286 {
 287   index_type rank;
 288   index_type dstride;
 289   index_type n;
 290   GFC_INTEGER_8 *dest;
 291
 292   if (*mask)
 293     {
 294       maxloc0_8_r16 (retarray, array);
 295       return;
 296     }
 297
 298   rank = GFC_DESCRIPTOR_RANK (array);
 299
 300   if (rank <= 0)
 301     runtime_error ("Rank of array needs to be > 0");
 302
 303   if (retarray->data == NULL)
 304     {
 305       retarray->dim[0].lbound = 0;
 306       retarray->dim[0].ubound = rank-1;
 307       retarray->dim[0].stride = 1;
 308       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 309       retarray->offset = 0;
 310       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank);
 311     }
 312   else
 313     {
 314       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 315         runtime_error ("rank of return array does not equal 1");
 316
 317       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 318         runtime_error ("dimension of return array incorrect");
 319     }
 320
 321   dstride = retarray->dim[0].stride;
 322   dest = retarray->data;
 323   for (n = 0; n<rank; n++)
 324     dest[n * dstride] = 0 ;
 325 }
 326 #endif