libgfortran/generated/maxloc0_4_r8.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_8) && defined (HAVE_GFC_INTEGER_4)
  38
  39
  40 extern void maxloc0_4_r8 (gfc_array_i4 * const restrict retarray,
  41         gfc_array_r8 * const restrict array);
  42 export_proto(maxloc0_4_r8);
  43
  44 void
  45 maxloc0_4_r8 (gfc_array_i4 * 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_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 (GFC_DESCRIPTOR_RANK (retarray) != 1)
  73         runtime_error ("rank of return array does not equal 1");
  74
  75       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
  76         runtime_error ("dimension of return array incorrect");
  77     }
  78
  79   dstride = retarray->dim[0].stride;
  80   dest = retarray->data;
  81   for (n = 0; n < rank; n++)
  82     {
  83       sstride[n] = array->dim[n].stride;
  84       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
  85       count[n] = 0;
  86       if (extent[n] <= 0)
  87         {
  88           /* Set the return value.  */
  89           for (n = 0; n < rank; n++)
  90             dest[n * dstride] = 0;
  91           return;
  92         }
  93     }
  94
  95   base = array->data;
  96
  97   /* Initialize the return value.  */
  98   for (n = 0; n < rank; n++)
  99     dest[n * dstride] = 0;
 100   {
 101
 102   GFC_REAL_8 maxval;
 103
 104   maxval = -GFC_REAL_8_HUGE;
 105
 106   while (base)
 107     {
 108       {
 109         /* Implementation start.  */
 110
 111   if (*base > maxval || !dest[0])
 112     {
 113       maxval = *base;
 114       for (n = 0; n < rank; n++)
 115         dest[n * dstride] = count[n] + 1;
 116     }
 117         /* Implementation end.  */
 118       }
 119       /* Advance to the next element.  */
 120       count[0]++;
 121       base += sstride[0];
 122       n = 0;
 123       while (count[n] == extent[n])
 124         {
 125           /* When we get to the end of a dimension, reset it and increment
 126              the next dimension.  */
 127           count[n] = 0;
 128           /* We could precalculate these products, but this is a less
 129              frequently used path so probably not worth it.  */
 130           base -= sstride[n] * extent[n];
 131           n++;
 132           if (n == rank)
 133             {
 134               /* Break out of the loop.  */
 135               base = NULL;
 136               break;
 137             }
 138           else
 139             {
 140               count[n]++;
 141               base += sstride[n];
 142             }
 143         }
 144     }
 145   }
 146 }
 147
 148
 149 extern void mmaxloc0_4_r8 (gfc_array_i4 * const restrict,
 150         gfc_array_r8 * const restrict, gfc_array_l1 * const restrict);
 151 export_proto(mmaxloc0_4_r8);
 152
 153 void
 154 mmaxloc0_4_r8 (gfc_array_i4 * const restrict retarray,
 155         gfc_array_r8 * const restrict array,
 156         gfc_array_l1 * const restrict mask)
 157 {
 158   index_type count[GFC_MAX_DIMENSIONS];
 159   index_type extent[GFC_MAX_DIMENSIONS];
 160   index_type sstride[GFC_MAX_DIMENSIONS];
 161   index_type mstride[GFC_MAX_DIMENSIONS];
 162   index_type dstride;
 163   GFC_INTEGER_4 *dest;
 164   const GFC_REAL_8 *base;
 165   GFC_LOGICAL_1 *mbase;
 166   int rank;
 167   index_type n;
 168   int mask_kind;
 169
 170   rank = GFC_DESCRIPTOR_RANK (array);
 171   if (rank <= 0)
 172     runtime_error ("Rank of array needs to be > 0");
 173
 174   if (retarray->data == NULL)
 175     {
 176       retarray->dim[0].lbound = 0;
 177       retarray->dim[0].ubound = rank-1;
 178       retarray->dim[0].stride = 1;
 179       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 180       retarray->offset = 0;
 181       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
 182     }
 183   else
 184     {
 185       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 186         runtime_error ("rank of return array does not equal 1");
 187
 188       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 189         runtime_error ("dimension of return array incorrect");
 190     }
 191
 192   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 193
 194   mbase = mask->data;
 195
 196   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 197 #ifdef HAVE_GFC_LOGICAL_16
 198       || mask_kind == 16
 199 #endif
 200       )
 201     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 202   else
 203     runtime_error ("Funny sized logical array");
 204
 205   dstride = retarray->dim[0].stride;
 206   dest = retarray->data;
 207   for (n = 0; n < rank; n++)
 208     {
 209       sstride[n] = array->dim[n].stride;
 210       mstride[n] = mask->dim[n].stride * mask_kind;
 211       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
 212       count[n] = 0;
 213       if (extent[n] <= 0)
 214         {
 215           /* Set the return value.  */
 216           for (n = 0; n < rank; n++)
 217             dest[n * dstride] = 0;
 218           return;
 219         }
 220     }
 221
 222   base = array->data;
 223
 224   /* Initialize the return value.  */
 225   for (n = 0; n < rank; n++)
 226     dest[n * dstride] = 0;
 227   {
 228
 229   GFC_REAL_8 maxval;
 230
 231   maxval = -GFC_REAL_8_HUGE;
 232
 233   while (base)
 234     {
 235       {
 236         /* Implementation start.  */
 237
 238   if (*mbase && (*base > maxval || !dest[0]))
 239     {
 240       maxval = *base;
 241       for (n = 0; n < rank; n++)
 242         dest[n * dstride] = count[n] + 1;
 243     }
 244         /* Implementation end.  */
 245       }
 246       /* Advance to the next element.  */
 247       count[0]++;
 248       base += sstride[0];
 249       mbase += mstride[0];
 250       n = 0;
 251       while (count[n] == extent[n])
 252         {
 253           /* When we get to the end of a dimension, reset it and increment
 254              the next dimension.  */
 255           count[n] = 0;
 256           /* We could precalculate these products, but this is a less
 257              frequently used path so probably not worth it.  */
 258           base -= sstride[n] * extent[n];
 259           mbase -= mstride[n] * extent[n];
 260           n++;
 261           if (n == rank)
 262             {
 263               /* Break out of the loop.  */
 264               base = NULL;
 265               break;
 266             }
 267           else
 268             {
 269               count[n]++;
 270               base += sstride[n];
 271               mbase += mstride[n];
 272             }
 273         }
 274     }
 275   }
 276 }
 277
 278
 279 extern void smaxloc0_4_r8 (gfc_array_i4 * const restrict,
 280         gfc_array_r8 * const restrict, GFC_LOGICAL_4 *);
 281 export_proto(smaxloc0_4_r8);
 282
 283 void
 284 smaxloc0_4_r8 (gfc_array_i4 * const restrict retarray,
 285         gfc_array_r8 * const restrict array,
 286         GFC_LOGICAL_4 * mask)
 287 {
 288   index_type rank;
 289   index_type dstride;
 290   index_type n;
 291   GFC_INTEGER_4 *dest;
 292
 293   if (*mask)
 294     {
 295       maxloc0_4_r8 (retarray, array);
 296       return;
 297     }
 298
 299   rank = GFC_DESCRIPTOR_RANK (array);
 300
 301   if (rank <= 0)
 302     runtime_error ("Rank of array needs to be > 0");
 303
 304   if (retarray->data == NULL)
 305     {
 306       retarray->dim[0].lbound = 0;
 307       retarray->dim[0].ubound = rank-1;
 308       retarray->dim[0].stride = 1;
 309       retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
 310       retarray->offset = 0;
 311       retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
 312     }
 313   else
 314     {
 315       if (GFC_DESCRIPTOR_RANK (retarray) != 1)
 316         runtime_error ("rank of return array does not equal 1");
 317
 318       if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
 319         runtime_error ("dimension of return array incorrect");
 320     }
 321
 322   dstride = retarray->dim[0].stride;
 323   dest = retarray->data;
 324   for (n = 0; n<rank; n++)
 325     dest[n * dstride] = 0 ;
 326 }
 327 #endif