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