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