libgfortran/generated/minval_i2.c

   1 /* Implementation of the MINVAL 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 "libgfortran.h"
  35
  36
  37 #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_2)
  38
  39
  40 extern void minval_i2 (gfc_array_i2 * const restrict,
  41         gfc_array_i2 * const restrict, const index_type * const restrict);
  42 export_proto(minval_i2);
  43
  44 void
  45 minval_i2 (gfc_array_i2 * const restrict retarray,
  46         gfc_array_i2 * const restrict array,
  47         const index_type * const restrict pdim)
  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[GFC_MAX_DIMENSIONS];
  53   const GFC_INTEGER_2 * restrict base;
  54   GFC_INTEGER_2 * restrict dest;
  55   index_type rank;
  56   index_type n;
  57   index_type len;
  58   index_type delta;
  59   index_type dim;
  60
  61   /* Make dim zero based to avoid confusion.  */
  62   dim = (*pdim) - 1;
  63   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  64
  65   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  66   delta = array->dim[dim].stride;
  67
  68   for (n = 0; n < dim; n++)
  69     {
  70       sstride[n] = array->dim[n].stride;
  71       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  72
  73       if (extent[n] < 0)
  74         extent[n] = 0;
  75     }
  76   for (n = dim; n < rank; n++)
  77     {
  78       sstride[n] = array->dim[n + 1].stride;
  79       extent[n] =
  80         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
  81
  82       if (extent[n] < 0)
  83         extent[n] = 0;
  84     }
  85
  86   if (retarray->data == NULL)
  87     {
  88       size_t alloc_size;
  89
  90       for (n = 0; n < rank; n++)
  91         {
  92           retarray->dim[n].lbound = 0;
  93           retarray->dim[n].ubound = extent[n]-1;
  94           if (n == 0)
  95             retarray->dim[n].stride = 1;
  96           else
  97             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
  98         }
  99
 100       retarray->offset = 0;
 101       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 102
 103       alloc_size = sizeof (GFC_INTEGER_2) * retarray->dim[rank-1].stride
 104                    * extent[rank-1];
 105
 106       if (alloc_size == 0)
 107         {
 108           /* Make sure we have a zero-sized array.  */
 109           retarray->dim[0].lbound = 0;
 110           retarray->dim[0].ubound = -1;
 111           return;
 112         }
 113       else
 114         retarray->data = internal_malloc_size (alloc_size);
 115     }
 116   else
 117     {
 118       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 119         runtime_error ("rank of return array incorrect");
 120     }
 121
 122   for (n = 0; n < rank; n++)
 123     {
 124       count[n] = 0;
 125       dstride[n] = retarray->dim[n].stride;
 126       if (extent[n] <= 0)
 127         len = 0;
 128     }
 129
 130   base = array->data;
 131   dest = retarray->data;
 132
 133   while (base)
 134     {
 135       const GFC_INTEGER_2 * restrict src;
 136       GFC_INTEGER_2 result;
 137       src = base;
 138       {
 139
 140   result = GFC_INTEGER_2_HUGE;
 141         if (len <= 0)
 142           *dest = GFC_INTEGER_2_HUGE;
 143         else
 144           {
 145             for (n = 0; n < len; n++, src += delta)
 146               {
 147
 148   if (*src < result)
 149     result = *src;
 150           }
 151             *dest = result;
 152           }
 153       }
 154       /* Advance to the next element.  */
 155       count[0]++;
 156       base += sstride[0];
 157       dest += dstride[0];
 158       n = 0;
 159       while (count[n] == extent[n])
 160         {
 161           /* When we get to the end of a dimension, reset it and increment
 162              the next dimension.  */
 163           count[n] = 0;
 164           /* We could precalculate these products, but this is a less
 165              frequently used path so probably not worth it.  */
 166           base -= sstride[n] * extent[n];
 167           dest -= dstride[n] * extent[n];
 168           n++;
 169           if (n == rank)
 170             {
 171               /* Break out of the look.  */
 172               base = NULL;
 173               break;
 174             }
 175           else
 176             {
 177               count[n]++;
 178               base += sstride[n];
 179               dest += dstride[n];
 180             }
 181         }
 182     }
 183 }
 184
 185
 186 extern void mminval_i2 (gfc_array_i2 * const restrict,
 187         gfc_array_i2 * const restrict, const index_type * const restrict,
 188         gfc_array_l1 * const restrict);
 189 export_proto(mminval_i2);
 190
 191 void
 192 mminval_i2 (gfc_array_i2 * const restrict retarray,
 193         gfc_array_i2 * const restrict array,
 194         const index_type * const restrict pdim,
 195         gfc_array_l1 * const restrict mask)
 196 {
 197   index_type count[GFC_MAX_DIMENSIONS];
 198   index_type extent[GFC_MAX_DIMENSIONS];
 199   index_type sstride[GFC_MAX_DIMENSIONS];
 200   index_type dstride[GFC_MAX_DIMENSIONS];
 201   index_type mstride[GFC_MAX_DIMENSIONS];
 202   GFC_INTEGER_2 * restrict dest;
 203   const GFC_INTEGER_2 * restrict base;
 204   const GFC_LOGICAL_1 * restrict mbase;
 205   int rank;
 206   int dim;
 207   index_type n;
 208   index_type len;
 209   index_type delta;
 210   index_type mdelta;
 211   int mask_kind;
 212
 213   dim = (*pdim) - 1;
 214   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 215
 216   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 217   if (len <= 0)
 218     return;
 219
 220   mbase = mask->data;
 221
 222   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 223
 224   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 225 #ifdef HAVE_GFC_LOGICAL_16
 226       || mask_kind == 16
 227 #endif
 228       )
 229     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 230   else
 231     runtime_error ("Funny sized logical array");
 232
 233   delta = array->dim[dim].stride;
 234   mdelta = mask->dim[dim].stride * mask_kind;
 235
 236   for (n = 0; n < dim; n++)
 237     {
 238       sstride[n] = array->dim[n].stride;
 239       mstride[n] = mask->dim[n].stride * mask_kind;
 240       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 241
 242       if (extent[n] < 0)
 243         extent[n] = 0;
 244
 245     }
 246   for (n = dim; n < rank; n++)
 247     {
 248       sstride[n] = array->dim[n + 1].stride;
 249       mstride[n] = mask->dim[n + 1].stride * mask_kind;
 250       extent[n] =
 251         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 252
 253       if (extent[n] < 0)
 254         extent[n] = 0;
 255     }
 256
 257   if (retarray->data == NULL)
 258     {
 259       size_t alloc_size;
 260
 261       for (n = 0; n < rank; n++)
 262         {
 263           retarray->dim[n].lbound = 0;
 264           retarray->dim[n].ubound = extent[n]-1;
 265           if (n == 0)
 266             retarray->dim[n].stride = 1;
 267           else
 268             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 269         }
 270
 271       alloc_size = sizeof (GFC_INTEGER_2) * retarray->dim[rank-1].stride
 272                    * extent[rank-1];
 273
 274       retarray->offset = 0;
 275       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 276
 277       if (alloc_size == 0)
 278         {
 279           /* Make sure we have a zero-sized array.  */
 280           retarray->dim[0].lbound = 0;
 281           retarray->dim[0].ubound = -1;
 282           return;
 283         }
 284       else
 285         retarray->data = internal_malloc_size (alloc_size);
 286
 287     }
 288   else
 289     {
 290       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 291         runtime_error ("rank of return array incorrect");
 292     }
 293
 294   for (n = 0; n < rank; n++)
 295     {
 296       count[n] = 0;
 297       dstride[n] = retarray->dim[n].stride;
 298       if (extent[n] <= 0)
 299         return;
 300     }
 301
 302   dest = retarray->data;
 303   base = array->data;
 304
 305   while (base)
 306     {
 307       const GFC_INTEGER_2 * restrict src;
 308       const GFC_LOGICAL_1 * restrict msrc;
 309       GFC_INTEGER_2 result;
 310       src = base;
 311       msrc = mbase;
 312       {
 313
 314   result = GFC_INTEGER_2_HUGE;
 315         if (len <= 0)
 316           *dest = GFC_INTEGER_2_HUGE;
 317         else
 318           {
 319             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 320               {
 321
 322   if (*msrc && *src < result)
 323     result = *src;
 324               }
 325             *dest = result;
 326           }
 327       }
 328       /* Advance to the next element.  */
 329       count[0]++;
 330       base += sstride[0];
 331       mbase += mstride[0];
 332       dest += dstride[0];
 333       n = 0;
 334       while (count[n] == extent[n])
 335         {
 336           /* When we get to the end of a dimension, reset it and increment
 337              the next dimension.  */
 338           count[n] = 0;
 339           /* We could precalculate these products, but this is a less
 340              frequently used path so probably not worth it.  */
 341           base -= sstride[n] * extent[n];
 342           mbase -= mstride[n] * extent[n];
 343           dest -= dstride[n] * extent[n];
 344           n++;
 345           if (n == rank)
 346             {
 347               /* Break out of the look.  */
 348               base = NULL;
 349               break;
 350             }
 351           else
 352             {
 353               count[n]++;
 354               base += sstride[n];
 355               mbase += mstride[n];
 356               dest += dstride[n];
 357             }
 358         }
 359     }
 360 }
 361
 362
 363 extern void sminval_i2 (gfc_array_i2 * const restrict,
 364         gfc_array_i2 * const restrict, const index_type * const restrict,
 365         GFC_LOGICAL_4 *);
 366 export_proto(sminval_i2);
 367
 368 void
 369 sminval_i2 (gfc_array_i2 * const restrict retarray,
 370         gfc_array_i2 * const restrict array,
 371         const index_type * const restrict pdim,
 372         GFC_LOGICAL_4 * mask)
 373 {
 374   index_type rank;
 375   index_type n;
 376   index_type dstride;
 377   GFC_INTEGER_2 *dest;
 378
 379   if (*mask)
 380     {
 381       minval_i2 (retarray, array, pdim);
 382       return;
 383     }
 384     rank = GFC_DESCRIPTOR_RANK (array);
 385   if (rank <= 0)
 386     runtime_error ("Rank of array needs to be > 0");
 387
 388   if (retarray->data == NULL)
 389     {
 390       retarray->dim[0].lbound = 0;
 391       retarray->dim[0].ubound = rank-1;
 392       retarray->dim[0].stride = 1;
 393       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 394       retarray->offset = 0;
 395       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_2) * rank);
 396     }
 397   else
 398     {
 399       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 400         runtime_error ("rank of return array does not equal 1");
 401
 402       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 403         runtime_error ("dimension of return array incorrect");
 404     }
 405
 406     dstride = retarray->dim[0].stride;
 407     dest = retarray->data;
 408
 409     for (n = 0; n < rank; n++)
 410       dest[n * dstride] = GFC_INTEGER_2_HUGE ;
 411 }
 412
 413 #endif