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