libgfortran/generated/minloc0_4_r4.c

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