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