libgfortran/generated/maxloc0_4_i4.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
  40 extern void maxloc0_4_i4 (gfc_array_i4 * retarray, gfc_array_i4 *array);
  41 export_proto(maxloc0_4_i4);
  42
  43 void
  44 maxloc0_4_i4 (gfc_array_i4 * retarray, gfc_array_i4 *array)
  45 {
  46   index_type count[GFC_MAX_DIMENSIONS];
  47   index_type extent[GFC_MAX_DIMENSIONS];
  48   index_type sstride[GFC_MAX_DIMENSIONS];
  49   index_type dstride;
  50   GFC_INTEGER_4 *base;
  51   GFC_INTEGER_4 *dest;
  52   index_type rank;
  53   index_type n;
  54
  55   rank = GFC_DESCRIPTOR_RANK (array);
  56   if (rank <= 0)
  57     runtime_error ("Rank of array needs to be > 0");
  58
  59   if (retarray->data == NULL)
  60     {
  61       retarray->dim[0].lbound = 0;
  62       retarray->dim[0].ubound = rank-1;
  63       retarray->dim[0].stride = 1;
  64       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
  65       retarray->offset = 0;
  66       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
  67     }
  68   else
  69     {
  70       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
  71         runtime_error ("rank of return array does not equal 1");
  72
  73       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
  74         runtime_error ("dimension of return array incorrect");
  75
  76       if (retarray->dim[0].stride == 0)
  77         retarray->dim[0].stride = 1;
  78     }
  79
  80   /* TODO:  It should be a front end job to correctly set the strides.  */
  81
  82   if (array->dim[0].stride == 0)
  83     array->dim[0].stride = 1;
  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] = 1;
 106   {
 107
 108   GFC_INTEGER_4 maxval;
 109
 110   maxval = -GFC_INTEGER_4_HUGE;
 111
 112   while (base)
 113     {
 114       {
 115         /* Implementation start.  */
 116
 117   if (*base > maxval)
 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 proabably 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_4_i4 (gfc_array_i4 *, gfc_array_i4 *, gfc_array_l4 *);
 156 export_proto(mmaxloc0_4_i4);
 157
 158 void
 159 mmaxloc0_4_i4 (gfc_array_i4 * retarray, gfc_array_i4 *array,
 160                                   gfc_array_l4 * 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_4 *dest;
 168   GFC_INTEGER_4 *base;
 169   GFC_LOGICAL_4 *mbase;
 170   int rank;
 171   index_type n;
 172
 173   rank = GFC_DESCRIPTOR_RANK (array);
 174   if (rank <= 0)
 175     runtime_error ("Rank of array needs to be > 0");
 176
 177   if (retarray->data == NULL)
 178     {
 179       retarray->dim[0].lbound = 0;
 180       retarray->dim[0].ubound = rank-1;
 181       retarray->dim[0].stride = 1;
 182       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 183       retarray->offset = 0;
 184       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
 185     }
 186   else
 187     {
 188       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 189         runtime_error ("rank of return array does not equal 1");
 190
 191       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 192         runtime_error ("dimension of return array incorrect");
 193
 194       if (retarray->dim[0].stride == 0)
 195         retarray->dim[0].stride = 1;
 196     }
 197
 198   /* TODO:  It should be a front end job to correctly set the strides.  */
 199
 200   if (array->dim[0].stride == 0)
 201     array->dim[0].stride = 1;
 202
 203   if (mask->dim[0].stride == 0)
 204     mask->dim[0].stride = 1;
 205
 206   dstride = retarray->dim[0].stride;
 207   dest = retarray->data;
 208   for (n = 0; n < rank; n++)
 209     {
 210       sstride[n] = array->dim[n].stride;
 211       mstride[n] = mask->dim[n].stride;
 212       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 213       count[n] = 0;
 214       if (extent[n] <= 0)
 215         {
 216           /* Set the return value.  */
 217           for (n = 0; n < rank; n++)
 218             dest[n * dstride] = 0;
 219           return;
 220         }
 221     }
 222
 223   base = array->data;
 224   mbase = mask->data;
 225
 226   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 227     {
 228       /* This allows the same loop to be used for all logical types.  */
 229       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 230       for (n = 0; n < rank; n++)
 231         mstride[n] <<= 1;
 232       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 233     }
 234
 235
 236   /* Initialize the return value.  */
 237   for (n = 0; n < rank; n++)
 238     dest[n * dstride] = 1;
 239   {
 240
 241   GFC_INTEGER_4 maxval;
 242
 243   maxval = -GFC_INTEGER_4_HUGE;
 244
 245   while (base)
 246     {
 247       {
 248         /* Implementation start.  */
 249
 250   if (*mbase && *base > maxval)
 251     {
 252       maxval = *base;
 253       for (n = 0; n < rank; n++)
 254         dest[n * dstride] = count[n] + 1;
 255     }
 256         /* Implementation end.  */
 257       }
 258       /* Advance to the next element.  */
 259       count[0]++;
 260       base += sstride[0];
 261       mbase += mstride[0];
 262       n = 0;
 263       while (count[n] == extent[n])
 264         {
 265           /* When we get to the end of a dimension, reset it and increment
 266              the next dimension.  */
 267           count[n] = 0;
 268           /* We could precalculate these products, but this is a less
 269              frequently used path so proabably not worth it.  */
 270           base -= sstride[n] * extent[n];
 271           mbase -= mstride[n] * extent[n];
 272           n++;
 273           if (n == rank)
 274             {
 275               /* Break out of the loop.  */
 276               base = NULL;
 277               break;
 278             }
 279           else
 280             {
 281               count[n]++;
 282               base += sstride[n];
 283               mbase += mstride[n];
 284             }
 285         }
 286     }
 287   }
 288 }