libgfortran/generated/minloc1_4_r10.c

   1 /* Implementation of the MINLOC intrinsic
   2    Copyright 2002, 2007 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 "libgfortran.h"
  32 #include <stdlib.h>
  33 #include <assert.h>
  34 #include <limits.h>
  35
  36
  37 #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_4)
  38
  39
  40 extern void minloc1_4_r10 (gfc_array_i4 * const restrict,
  41         gfc_array_r10 * const restrict, const index_type * const restrict);
  42 export_proto(minloc1_4_r10);
  43
  44 void
  45 minloc1_4_r10 (gfc_array_i4 * const restrict retarray,
  46         gfc_array_r10 * 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_REAL_10 * restrict base;
  54   GFC_INTEGER_4 * 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_4) * 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_REAL_10 * restrict src;
 136       GFC_INTEGER_4 result;
 137       src = base;
 138       {
 139
 140   GFC_REAL_10 minval;
 141   minval = GFC_REAL_10_HUGE;
 142   result = 0;
 143         if (len <= 0)
 144           *dest = 0;
 145         else
 146           {
 147             for (n = 0; n < len; n++, src += delta)
 148               {
 149
 150   if (*src < minval || !result)
 151     {
 152       minval = *src;
 153       result = (GFC_INTEGER_4)n + 1;
 154     }
 155           }
 156             *dest = result;
 157           }
 158       }
 159       /* Advance to the next element.  */
 160       count[0]++;
 161       base += sstride[0];
 162       dest += dstride[0];
 163       n = 0;
 164       while (count[n] == extent[n])
 165         {
 166           /* When we get to the end of a dimension, reset it and increment
 167              the next dimension.  */
 168           count[n] = 0;
 169           /* We could precalculate these products, but this is a less
 170              frequently used path so probably not worth it.  */
 171           base -= sstride[n] * extent[n];
 172           dest -= dstride[n] * extent[n];
 173           n++;
 174           if (n == rank)
 175             {
 176               /* Break out of the look.  */
 177               base = NULL;
 178               break;
 179             }
 180           else
 181             {
 182               count[n]++;
 183               base += sstride[n];
 184               dest += dstride[n];
 185             }
 186         }
 187     }
 188 }
 189
 190
 191 extern void mminloc1_4_r10 (gfc_array_i4 * const restrict,
 192         gfc_array_r10 * const restrict, const index_type * const restrict,
 193         gfc_array_l1 * const restrict);
 194 export_proto(mminloc1_4_r10);
 195
 196 void
 197 mminloc1_4_r10 (gfc_array_i4 * const restrict retarray,
 198         gfc_array_r10 * const restrict array,
 199         const index_type * const restrict pdim,
 200         gfc_array_l1 * const restrict mask)
 201 {
 202   index_type count[GFC_MAX_DIMENSIONS];
 203   index_type extent[GFC_MAX_DIMENSIONS];
 204   index_type sstride[GFC_MAX_DIMENSIONS];
 205   index_type dstride[GFC_MAX_DIMENSIONS];
 206   index_type mstride[GFC_MAX_DIMENSIONS];
 207   GFC_INTEGER_4 * restrict dest;
 208   const GFC_REAL_10 * restrict base;
 209   const GFC_LOGICAL_1 * restrict mbase;
 210   int rank;
 211   int dim;
 212   index_type n;
 213   index_type len;
 214   index_type delta;
 215   index_type mdelta;
 216   int mask_kind;
 217
 218   dim = (*pdim) - 1;
 219   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 220
 221   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
 222   if (len <= 0)
 223     return;
 224
 225   mbase = mask->data;
 226
 227   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 228
 229   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 230 #ifdef HAVE_GFC_LOGICAL_16
 231       || mask_kind == 16
 232 #endif
 233       )
 234     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 235   else
 236     runtime_error ("Funny sized logical array");
 237
 238   delta = array->dim[dim].stride;
 239   mdelta = mask->dim[dim].stride * mask_kind;
 240
 241   for (n = 0; n < dim; n++)
 242     {
 243       sstride[n] = array->dim[n].stride;
 244       mstride[n] = mask->dim[n].stride * mask_kind;
 245       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 246
 247       if (extent[n] < 0)
 248         extent[n] = 0;
 249
 250     }
 251   for (n = dim; n < rank; n++)
 252     {
 253       sstride[n] = array->dim[n + 1].stride;
 254       mstride[n] = mask->dim[n + 1].stride * mask_kind;
 255       extent[n] =
 256         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
 257
 258       if (extent[n] < 0)
 259         extent[n] = 0;
 260     }
 261
 262   if (retarray->data == NULL)
 263     {
 264       size_t alloc_size;
 265
 266       for (n = 0; n < rank; n++)
 267         {
 268           retarray->dim[n].lbound = 0;
 269           retarray->dim[n].ubound = extent[n]-1;
 270           if (n == 0)
 271             retarray->dim[n].stride = 1;
 272           else
 273             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
 274         }
 275
 276       alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
 277                    * extent[rank-1];
 278
 279       retarray->offset = 0;
 280       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 281
 282       if (alloc_size == 0)
 283         {
 284           /* Make sure we have a zero-sized array.  */
 285           retarray->dim[0].lbound = 0;
 286           retarray->dim[0].ubound = -1;
 287           return;
 288         }
 289       else
 290         retarray->data = internal_malloc_size (alloc_size);
 291
 292     }
 293   else
 294     {
 295       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 296         runtime_error ("rank of return array incorrect");
 297     }
 298
 299   for (n = 0; n < rank; n++)
 300     {
 301       count[n] = 0;
 302       dstride[n] = retarray->dim[n].stride;
 303       if (extent[n] <= 0)
 304         return;
 305     }
 306
 307   dest = retarray->data;
 308   base = array->data;
 309
 310   while (base)
 311     {
 312       const GFC_REAL_10 * restrict src;
 313       const GFC_LOGICAL_1 * restrict msrc;
 314       GFC_INTEGER_4 result;
 315       src = base;
 316       msrc = mbase;
 317       {
 318
 319   GFC_REAL_10 minval;
 320   minval = GFC_REAL_10_HUGE;
 321   result = 0;
 322         if (len <= 0)
 323           *dest = 0;
 324         else
 325           {
 326             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 327               {
 328
 329   if (*msrc && (*src < minval || !result))
 330     {
 331       minval = *src;
 332       result = (GFC_INTEGER_4)n + 1;
 333     }
 334               }
 335             *dest = result;
 336           }
 337       }
 338       /* Advance to the next element.  */
 339       count[0]++;
 340       base += sstride[0];
 341       mbase += mstride[0];
 342       dest += dstride[0];
 343       n = 0;
 344       while (count[n] == extent[n])
 345         {
 346           /* When we get to the end of a dimension, reset it and increment
 347              the next dimension.  */
 348           count[n] = 0;
 349           /* We could precalculate these products, but this is a less
 350              frequently used path so probably not worth it.  */
 351           base -= sstride[n] * extent[n];
 352           mbase -= mstride[n] * extent[n];
 353           dest -= dstride[n] * extent[n];
 354           n++;
 355           if (n == rank)
 356             {
 357               /* Break out of the look.  */
 358               base = NULL;
 359               break;
 360             }
 361           else
 362             {
 363               count[n]++;
 364               base += sstride[n];
 365               mbase += mstride[n];
 366               dest += dstride[n];
 367             }
 368         }
 369     }
 370 }
 371
 372
 373 extern void sminloc1_4_r10 (gfc_array_i4 * const restrict,
 374         gfc_array_r10 * const restrict, const index_type * const restrict,
 375         GFC_LOGICAL_4 *);
 376 export_proto(sminloc1_4_r10);
 377
 378 void
 379 sminloc1_4_r10 (gfc_array_i4 * const restrict retarray,
 380         gfc_array_r10 * const restrict array,
 381         const index_type * const restrict pdim,
 382         GFC_LOGICAL_4 * mask)
 383 {
 384   index_type rank;
 385   index_type n;
 386   index_type dstride;
 387   GFC_INTEGER_4 *dest;
 388
 389   if (*mask)
 390     {
 391       minloc1_4_r10 (retarray, array, pdim);
 392       return;
 393     }
 394     rank = GFC_DESCRIPTOR_RANK (array);
 395   if (rank <= 0)
 396     runtime_error ("Rank of array needs to be > 0");
 397
 398   if (retarray->data == NULL)
 399     {
 400       retarray->dim[0].lbound = 0;
 401       retarray->dim[0].ubound = rank-1;
 402       retarray->dim[0].stride = 1;
 403       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 404       retarray->offset = 0;
 405       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
 406     }
 407   else
 408     {
 409       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 410         runtime_error ("rank of return array does not equal 1");
 411
 412       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 413         runtime_error ("dimension of return array incorrect");
 414     }
 415
 416     dstride = retarray->dim[0].stride;
 417     dest = retarray->data;
 418
 419     for (n = 0; n < rank; n++)
 420       dest[n * dstride] = 0 ;
 421 }
 422
 423 #endif