libgfortran/generated/maxloc1_4_r10.c

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