libgfortran/generated/minloc1_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., 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 minloc1_4_r4 (gfc_array_i4 *, gfc_array_r4 *, index_type *);
  40 export_proto(minloc1_4_r4);
  41
  42 void
  43 minloc1_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 minval;
 125   minval = 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 < minval)
 135     {
 136       minval = *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 mminloc1_4_r4 (gfc_array_i4 *, gfc_array_r4 *, index_type *,
 176                                                gfc_array_l4 *);
 177 export_proto(mminloc1_4_r4);
 178
 179 void
 180 mminloc1_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   if (mask->dim[0].stride == 0)
 204     mask->dim[0].stride = 1;
 205
 206   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 207   if (len <= 0)
 208     return;
 209   delta = array->dim[dim].stride;
 210   mdelta = mask->dim[dim].stride;
 211
 212   for (n = 0; n < dim; n++)
 213     {
 214       sstride[n] = array->dim[n].stride;
 215       mstride[n] = mask->dim[n].stride;
 216       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 217     }
 218   for (n = dim; n < rank; n++)
 219     {
 220       sstride[n] = array->dim[n + 1].stride;
 221       mstride[n] = mask->dim[n + 1].stride;
 222       extent[n] =
 223         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 224     }
 225
 226   if (retarray->data == NULL)
 227     {
 228       for (n = 0; n < rank; n++)
 229         {
 230           retarray->dim[n].lbound = 0;
 231           retarray->dim[n].ubound = extent[n]-1;
 232           if (n == 0)
 233             retarray->dim[n].stride = 1;
 234           else
 235             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 236         }
 237
 238       retarray->data
 239          = internal_malloc_size (sizeof (GFC_INTEGER_4)
 240                                  * retarray->dim[rank-1].stride
 241                                  * extent[rank-1]);
 242       retarray->base = 0;
 243       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 244     }
 245   else
 246     {
 247       if (retarray->dim[0].stride == 0)
 248         retarray->dim[0].stride = 1;
 249
 250       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 251         runtime_error ("rank of return array incorrect");
 252     }
 253
 254   for (n = 0; n < rank; n++)
 255     {
 256       count[n] = 0;
 257       dstride[n] = retarray->dim[n].stride;
 258       if (extent[n] <= 0)
 259         return;
 260     }
 261
 262   dest = retarray->data;
 263   base = array->data;
 264   mbase = mask->data;
 265
 266   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
 267     {
 268       /* This allows the same loop to be used for all logical types.  */
 269       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
 270       for (n = 0; n < rank; n++)
 271         mstride[n] <<= 1;
 272       mdelta <<= 1;
 273       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
 274     }
 275
 276   while (base)
 277     {
 278       GFC_REAL_4 *src;
 279       GFC_LOGICAL_4 *msrc;
 280       GFC_INTEGER_4 result;
 281       src = base;
 282       msrc = mbase;
 283       {
 284
 285   GFC_REAL_4 minval;
 286   minval = GFC_REAL_4_HUGE;
 287   result = 1;
 288         if (len <= 0)
 289           *dest = 0;
 290         else
 291           {
 292             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 293               {
 294
 295   if (*msrc && *src < minval)
 296     {
 297       minval = *src;
 298       result = (GFC_INTEGER_4)n + 1;
 299     }
 300               }
 301             *dest = result;
 302           }
 303       }
 304       /* Advance to the next element.  */
 305       count[0]++;
 306       base += sstride[0];
 307       mbase += mstride[0];
 308       dest += dstride[0];
 309       n = 0;
 310       while (count[n] == extent[n])
 311         {
 312           /* When we get to the end of a dimension, reset it and increment
 313              the next dimension.  */
 314           count[n] = 0;
 315           /* We could precalculate these products, but this is a less
 316              frequently used path so proabably not worth it.  */
 317           base -= sstride[n] * extent[n];
 318           mbase -= mstride[n] * extent[n];
 319           dest -= dstride[n] * extent[n];
 320           n++;
 321           if (n == rank)
 322             {
 323               /* Break out of the look.  */
 324               base = NULL;
 325               break;
 326             }
 327           else
 328             {
 329               count[n]++;
 330               base += sstride[n];
 331               mbase += mstride[n];
 332               dest += dstride[n];
 333             }
 334         }
 335     }
 336 }
 337