libgfortran/generated/minloc0_4_r4.c

   1 /* Implementation of the MINLOC intrinsic
   2    Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version.
  11
  12 Libgfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "libgfortran.h"
  27 #include <stdlib.h>
  28 #include <assert.h>
  29 #include <limits.h>
  30
  31
  32 #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4)
  33
  34
  35 extern void minloc0_4_r4 (gfc_array_i4 * const restrict retarray,
  36         gfc_array_r4 * const restrict array);
  37 export_proto(minloc0_4_r4);
  38
  39 void
  40 minloc0_4_r4 (gfc_array_i4 * const restrict retarray,
  41         gfc_array_r4 * const restrict array)
  42 {
  43   index_type count[GFC_MAX_DIMENSIONS];
  44   index_type extent[GFC_MAX_DIMENSIONS];
  45   index_type sstride[GFC_MAX_DIMENSIONS];
  46   index_type dstride;
  47   const GFC_REAL_4 *base;
  48   GFC_INTEGER_4 * restrict dest;
  49   index_type rank;
  50   index_type n;
  51
  52   rank = GFC_DESCRIPTOR_RANK (array);
  53   if (rank <= 0)
  54     runtime_error ("Rank of array needs to be > 0");
  55
  56   if (retarray->data == NULL)
  57     {
  58       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
  59       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
  60       retarray->offset = 0;
  61       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
  62     }
  63   else
  64     {
  65       if (unlikely (compile_options.bounds_check))
  66         bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
  67                                 "MINLOC");
  68     }
  69
  70   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  71   dest = retarray->data;
  72   for (n = 0; n < rank; n++)
  73     {
  74       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
  75       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  76       count[n] = 0;
  77       if (extent[n] <= 0)
  78         {
  79           /* Set the return value.  */
  80           for (n = 0; n < rank; n++)
  81             dest[n * dstride] = 0;
  82           return;
  83         }
  84     }
  85
  86   base = array->data;
  87
  88   /* Initialize the return value.  */
  89   for (n = 0; n < rank; n++)
  90     dest[n * dstride] = 0;
  91   {
  92
  93   GFC_REAL_4 minval;
  94
  95   minval = GFC_REAL_4_HUGE;
  96
  97   while (base)
  98     {
  99       {
 100         /* Implementation start.  */
 101
 102   if (*base < minval || !dest[0])
 103     {
 104       minval = *base;
 105       for (n = 0; n < rank; n++)
 106         dest[n * dstride] = count[n] + 1;
 107     }
 108         /* Implementation end.  */
 109       }
 110       /* Advance to the next element.  */
 111       count[0]++;
 112       base += sstride[0];
 113       n = 0;
 114       while (count[n] == extent[n])
 115         {
 116           /* When we get to the end of a dimension, reset it and increment
 117              the next dimension.  */
 118           count[n] = 0;
 119           /* We could precalculate these products, but this is a less
 120              frequently used path so probably not worth it.  */
 121           base -= sstride[n] * extent[n];
 122           n++;
 123           if (n == rank)
 124             {
 125               /* Break out of the loop.  */
 126               base = NULL;
 127               break;
 128             }
 129           else
 130             {
 131               count[n]++;
 132               base += sstride[n];
 133             }
 134         }
 135     }
 136   }
 137 }
 138
 139
 140 extern void mminloc0_4_r4 (gfc_array_i4 * const restrict,
 141         gfc_array_r4 * const restrict, gfc_array_l1 * const restrict);
 142 export_proto(mminloc0_4_r4);
 143
 144 void
 145 mminloc0_4_r4 (gfc_array_i4 * const restrict retarray,
 146         gfc_array_r4 * const restrict array,
 147         gfc_array_l1 * const restrict mask)
 148 {
 149   index_type count[GFC_MAX_DIMENSIONS];
 150   index_type extent[GFC_MAX_DIMENSIONS];
 151   index_type sstride[GFC_MAX_DIMENSIONS];
 152   index_type mstride[GFC_MAX_DIMENSIONS];
 153   index_type dstride;
 154   GFC_INTEGER_4 *dest;
 155   const GFC_REAL_4 *base;
 156   GFC_LOGICAL_1 *mbase;
 157   int rank;
 158   index_type n;
 159   int mask_kind;
 160
 161   rank = GFC_DESCRIPTOR_RANK (array);
 162   if (rank <= 0)
 163     runtime_error ("Rank of array needs to be > 0");
 164
 165   if (retarray->data == NULL)
 166     {
 167       GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
 168       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 169       retarray->offset = 0;
 170       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
 171     }
 172   else
 173     {
 174       if (unlikely (compile_options.bounds_check))
 175         {
 176
 177           bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 178                                   "MINLOC");
 179           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 180                                   "MASK argument", "MINLOC");
 181         }
 182     }
 183
 184   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 185
 186   mbase = mask->data;
 187
 188   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 189 #ifdef HAVE_GFC_LOGICAL_16
 190       || mask_kind == 16
 191 #endif
 192       )
 193     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 194   else
 195     runtime_error ("Funny sized logical array");
 196
 197   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 198   dest = retarray->data;
 199   for (n = 0; n < rank; n++)
 200     {
 201       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
 202       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 203       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 204       count[n] = 0;
 205       if (extent[n] <= 0)
 206         {
 207           /* Set the return value.  */
 208           for (n = 0; n < rank; n++)
 209             dest[n * dstride] = 0;
 210           return;
 211         }
 212     }
 213
 214   base = array->data;
 215
 216   /* Initialize the return value.  */
 217   for (n = 0; n < rank; n++)
 218     dest[n * dstride] = 0;
 219   {
 220
 221   GFC_REAL_4 minval;
 222
 223   minval = GFC_REAL_4_HUGE;
 224
 225   while (base)
 226     {
 227       {
 228         /* Implementation start.  */
 229
 230   if (*mbase && (*base < minval || !dest[0]))
 231     {
 232       minval = *base;
 233       for (n = 0; n < rank; n++)
 234         dest[n * dstride] = count[n] + 1;
 235     }
 236         /* Implementation end.  */
 237       }
 238       /* Advance to the next element.  */
 239       count[0]++;
 240       base += sstride[0];
 241       mbase += mstride[0];
 242       n = 0;
 243       while (count[n] == extent[n])
 244         {
 245           /* When we get to the end of a dimension, reset it and increment
 246              the next dimension.  */
 247           count[n] = 0;
 248           /* We could precalculate these products, but this is a less
 249              frequently used path so probably not worth it.  */
 250           base -= sstride[n] * extent[n];
 251           mbase -= mstride[n] * extent[n];
 252           n++;
 253           if (n == rank)
 254             {
 255               /* Break out of the loop.  */
 256               base = NULL;
 257               break;
 258             }
 259           else
 260             {
 261               count[n]++;
 262               base += sstride[n];
 263               mbase += mstride[n];
 264             }
 265         }
 266     }
 267   }
 268 }
 269
 270
 271 extern void sminloc0_4_r4 (gfc_array_i4 * const restrict,
 272         gfc_array_r4 * const restrict, GFC_LOGICAL_4 *);
 273 export_proto(sminloc0_4_r4);
 274
 275 void
 276 sminloc0_4_r4 (gfc_array_i4 * const restrict retarray,
 277         gfc_array_r4 * const restrict array,
 278         GFC_LOGICAL_4 * mask)
 279 {
 280   index_type rank;
 281   index_type dstride;
 282   index_type n;
 283   GFC_INTEGER_4 *dest;
 284
 285   if (*mask)
 286     {
 287       minloc0_4_r4 (retarray, array);
 288       return;
 289     }
 290
 291   rank = GFC_DESCRIPTOR_RANK (array);
 292
 293   if (rank <= 0)
 294     runtime_error ("Rank of array needs to be > 0");
 295
 296   if (retarray->data == NULL)
 297     {
 298       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
 299       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 300       retarray->offset = 0;
 301       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
 302     }
 303   else if (unlikely (compile_options.bounds_check))
 304     {
 305        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
 306                                "MINLOC");
 307     }
 308
 309   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
 310   dest = retarray->data;
 311   for (n = 0; n<rank; n++)
 312     dest[n * dstride] = 0 ;
 313 }
 314 #endif