libgfortran/generated/maxloc0_4_r10.c

   1 /* Implementation of the MAXLOC 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 maxloc0_4_r10 (gfc_array_i4 * const restrict retarray,
  41         gfc_array_r10 * const restrict array);
  42 export_proto(maxloc0_4_r10);
  43
  44 void
  45 maxloc0_4_r10 (gfc_array_i4 * const restrict retarray,
  46         gfc_array_r10 * 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_10 *base;
  53   GFC_INTEGER_4 *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_4) * 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 MAXLOC intrinsic"
  80                            " should be 1, is %d", 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                            " MAXLOC intrnisic: is %ld, should be %d",
  86                            (long int) ret_extent, 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_10 maxval;
 114
 115   maxval = -GFC_REAL_10_HUGE;
 116
 117   while (base)
 118     {
 119       {
 120         /* Implementation start.  */
 121
 122   if (*base > maxval || !dest[0])
 123     {
 124       maxval = *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 mmaxloc0_4_r10 (gfc_array_i4 * const restrict,
 161         gfc_array_r10 * const restrict, gfc_array_l1 * const restrict);
 162 export_proto(mmaxloc0_4_r10);
 163
 164 void
 165 mmaxloc0_4_r10 (gfc_array_i4 * const restrict retarray,
 166         gfc_array_r10 * 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_4 *dest;
 175   const GFC_REAL_10 *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_4) * 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 MAXLOC intrinsic"
 206                            " should be 1, is %d", 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                            " MAXLOC intrnisic: is %ld, should be %d",
 212                            (long int) ret_extent, rank);
 213
 214           mask_rank = GFC_DESCRIPTOR_RANK (mask);
 215           if (rank != mask_rank)
 216             runtime_error ("rank of MASK argument in MAXLOC intrnisic"
 217                            "should be %d, is %d", rank, mask_rank);
 218
 219           for (n=0; n<rank; n++)
 220             {
 221               array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
 222               mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
 223               if (array_extent != mask_extent)
 224                 runtime_error ("Incorrect extent in MASK argument of"
 225                                " MAXLOC intrinsic in dimension %d:"
 226                                " is %ld, should be %ld", n + 1,
 227                                (long int) mask_extent, (long int) array_extent);
 228             }
 229         }
 230     }
 231
 232   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 233
 234   mbase = mask->data;
 235
 236   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 237 #ifdef HAVE_GFC_LOGICAL_16
 238       || mask_kind == 16
 239 #endif
 240       )
 241     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 242   else
 243     runtime_error ("Funny sized logical array");
 244
 245   dstride = retarray->dim[0].stride;
 246   dest = retarray->data;
 247   for (n = 0; n < rank; n++)
 248     {
 249       sstride[n] = array->dim[n].stride;
 250       mstride[n] = mask->dim[n].stride * mask_kind;
 251       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 252       count[n] = 0;
 253       if (extent[n] <= 0)
 254         {
 255           /* Set the return value.  */
 256           for (n = 0; n < rank; n++)
 257             dest[n * dstride] = 0;
 258           return;
 259         }
 260     }
 261
 262   base = array->data;
 263
 264   /* Initialize the return value.  */
 265   for (n = 0; n < rank; n++)
 266     dest[n * dstride] = 0;
 267   {
 268
 269   GFC_REAL_10 maxval;
 270
 271   maxval = -GFC_REAL_10_HUGE;
 272
 273   while (base)
 274     {
 275       {
 276         /* Implementation start.  */
 277
 278   if (*mbase && (*base > maxval || !dest[0]))
 279     {
 280       maxval = *base;
 281       for (n = 0; n < rank; n++)
 282         dest[n * dstride] = count[n] + 1;
 283     }
 284         /* Implementation end.  */
 285       }
 286       /* Advance to the next element.  */
 287       count[0]++;
 288       base += sstride[0];
 289       mbase += mstride[0];
 290       n = 0;
 291       while (count[n] == extent[n])
 292         {
 293           /* When we get to the end of a dimension, reset it and increment
 294              the next dimension.  */
 295           count[n] = 0;
 296           /* We could precalculate these products, but this is a less
 297              frequently used path so probably not worth it.  */
 298           base -= sstride[n] * extent[n];
 299           mbase -= mstride[n] * extent[n];
 300           n++;
 301           if (n == rank)
 302             {
 303               /* Break out of the loop.  */
 304               base = NULL;
 305               break;
 306             }
 307           else
 308             {
 309               count[n]++;
 310               base += sstride[n];
 311               mbase += mstride[n];
 312             }
 313         }
 314     }
 315   }
 316 }
 317
 318
 319 extern void smaxloc0_4_r10 (gfc_array_i4 * const restrict,
 320         gfc_array_r10 * const restrict, GFC_LOGICAL_4 *);
 321 export_proto(smaxloc0_4_r10);
 322
 323 void
 324 smaxloc0_4_r10 (gfc_array_i4 * const restrict retarray,
 325         gfc_array_r10 * const restrict array,
 326         GFC_LOGICAL_4 * mask)
 327 {
 328   index_type rank;
 329   index_type dstride;
 330   index_type n;
 331   GFC_INTEGER_4 *dest;
 332
 333   if (*mask)
 334     {
 335       maxloc0_4_r10 (retarray, array);
 336       return;
 337     }
 338
 339   rank = GFC_DESCRIPTOR_RANK (array);
 340
 341   if (rank <= 0)
 342     runtime_error ("Rank of array needs to be > 0");
 343
 344   if (retarray->data == NULL)
 345     {
 346       retarray->dim[0].lbound = 0;
 347       retarray->dim[0].ubound = rank-1;
 348       retarray->dim[0].stride = 1;
 349       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 350       retarray->offset = 0;
 351       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
 352     }
 353   else
 354     {
 355       if (compile_options.bounds_check)
 356         {
 357           int ret_rank;
 358           index_type ret_extent;
 359
 360           ret_rank = GFC_DESCRIPTOR_RANK (retarray);
 361           if (ret_rank != 1)
 362             runtime_error ("rank of return array in MAXLOC intrinsic"
 363                            " should be 1, is %d", ret_rank);
 364
 365           ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
 366             if (ret_extent != rank)
 367               runtime_error ("dimension of return array incorrect");
 368         }
 369     }
 370
 371   dstride = retarray->dim[0].stride;
 372   dest = retarray->data;
 373   for (n = 0; n<rank; n++)
 374     dest[n * dstride] = 0 ;
 375 }
 376 #endif