URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [generated/] [maxval_r8.c] - Blame information for rev 860

Go to most recent revision | Details | Compare with Previous | View Log


/* Implementation of the MAXVAL intrinsic
   Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>
 
This file is part of the GNU Fortran runtime library (libgfortran).
 
Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.
 
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.
 
Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.
 
You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */
 
#include "libgfortran.h"
#include <stdlib.h>
#include <assert.h>
 
 
#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8)
 
 
extern void maxval_r8 (gfc_array_r8 * const restrict,
        gfc_array_r8 * const restrict, const index_type * const restrict);
export_proto(maxval_r8);
 
void
maxval_r8 (gfc_array_r8 * const restrict retarray,
        gfc_array_r8 * const restrict array,
        const index_type * const restrict pdim)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_REAL_8 * restrict base;
  GFC_REAL_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;
 
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
 
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len < 0)
    len = 0;
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
 
  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 
      if (extent[n] < 0)
        extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 
      if (extent[n] < 0)
        extent[n] = 0;
    }
 
  if (retarray->data == NULL)
    {
      size_t alloc_size, str;
 
      for (n = 0; n < rank; n++)
        {
          if (n == 0)
            str = 1;
          else
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 
        }
 
      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 
      alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
                   * extent[rank-1];
 
      retarray->data = internal_malloc_size (alloc_size);
      if (alloc_size == 0)
        {
          /* Make sure we have a zero-sized array.  */
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
          return;
 
        }
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
        runtime_error ("rank of return array incorrect in"
                       " MAXVAL intrinsic: is %ld, should be %ld",
                       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
                       (long int) rank);
 
      if (unlikely (compile_options.bounds_check))
        bounds_ifunction_return ((array_t *) retarray, extent,
                                 "return value", "MAXVAL");
    }
 
  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
        return;
    }
 
  base = array->data;
  dest = retarray->data;
 
  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_REAL_8 * restrict src;
      GFC_REAL_8 result;
      src = base;
      {
 
#if defined (GFC_REAL_8_INFINITY)
        result = -GFC_REAL_8_INFINITY;
#else
        result = -GFC_REAL_8_HUGE;
#endif
        if (len <= 0)
          *dest = -GFC_REAL_8_HUGE;
        else
          {
            for (n = 0; n < len; n++, src += delta)
              {
 
#if defined (GFC_REAL_8_QUIET_NAN)
                if (*src >= result)
                  break;
              }
            if (unlikely (n >= len))
              result = GFC_REAL_8_QUIET_NAN;
            else for (; n < len; n++, src += delta)
              {
#endif
                if (*src > result)
                  result = *src;
              }
 
            *dest = result;
          }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          count[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          base -= sstride[n] * extent[n];
          dest -= dstride[n] * extent[n];
          n++;
          if (n == rank)
            {
              /* Break out of the look.  */
              continue_loop = 0;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              dest += dstride[n];
            }
        }
    }
}
 
 
extern void mmaxval_r8 (gfc_array_r8 * const restrict,
        gfc_array_r8 * const restrict, const index_type * const restrict,
        gfc_array_l1 * const restrict);
export_proto(mmaxval_r8);
 
void
mmaxval_r8 (gfc_array_r8 * const restrict retarray,
        gfc_array_r8 * const restrict array,
        const index_type * const restrict pdim,
        gfc_array_l1 * const restrict mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_REAL_8 * restrict dest;
  const GFC_REAL_8 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;
 
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
 
  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len <= 0)
    return;
 
  mbase = mask->data;
 
  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 
  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
  else
    runtime_error ("Funny sized logical array");
 
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 
  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 
      if (extent[n] < 0)
        extent[n] = 0;
 
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 
      if (extent[n] < 0)
        extent[n] = 0;
    }
 
  if (retarray->data == NULL)
    {
      size_t alloc_size, str;
 
      for (n = 0; n < rank; n++)
        {
          if (n == 0)
            str = 1;
          else
            str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 
        }
 
      alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
                   * extent[rank-1];
 
      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 
      if (alloc_size == 0)
        {
          /* Make sure we have a zero-sized array.  */
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
          return;
        }
      else
        retarray->data = internal_malloc_size (alloc_size);
 
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
        runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
 
      if (unlikely (compile_options.bounds_check))
        {
          bounds_ifunction_return ((array_t *) retarray, extent,
                                   "return value", "MAXVAL");
          bounds_equal_extents ((array_t *) mask, (array_t *) array,
                                "MASK argument", "MAXVAL");
        }
    }
 
  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
        return;
    }
 
  dest = retarray->data;
  base = array->data;
 
  while (base)
    {
      const GFC_REAL_8 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_REAL_8 result;
      src = base;
      msrc = mbase;
      {
 
#if defined (GFC_REAL_8_INFINITY)
        result = -GFC_REAL_8_INFINITY;
#else
        result = -GFC_REAL_8_HUGE;
#endif
#if defined (GFC_REAL_8_QUIET_NAN)
        int non_empty_p = 0;
#endif
        if (len <= 0)
          *dest = -GFC_REAL_8_HUGE;
        else
          {
            for (n = 0; n < len; n++, src += delta, msrc += mdelta)
              {
 
#if defined (GFC_REAL_8_INFINITY) || defined (GFC_REAL_8_QUIET_NAN)
                if (*msrc)
                  {
#if defined (GFC_REAL_8_QUIET_NAN)
                    non_empty_p = 1;
                    if (*src >= result)
#endif
                      break;
                  }
              }
            if (unlikely (n >= len))
              {
#if defined (GFC_REAL_8_QUIET_NAN)
                result = non_empty_p ? GFC_REAL_8_QUIET_NAN : -GFC_REAL_8_HUGE;
#else
                result = -GFC_REAL_8_HUGE;
#endif
              }
            else for (; n < len; n++, src += delta, msrc += mdelta)
              {
#endif
                if (*msrc && *src > result)
                  result = *src;
              }
            *dest = result;
          }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          count[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          base -= sstride[n] * extent[n];
          mbase -= mstride[n] * extent[n];
          dest -= dstride[n] * extent[n];
          n++;
          if (n == rank)
            {
              /* Break out of the look.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              mbase += mstride[n];
              dest += dstride[n];
            }
        }
    }
}
 
 
extern void smaxval_r8 (gfc_array_r8 * const restrict,
        gfc_array_r8 * const restrict, const index_type * const restrict,
        GFC_LOGICAL_4 *);
export_proto(smaxval_r8);
 
void
smaxval_r8 (gfc_array_r8 * const restrict retarray,
        gfc_array_r8 * const restrict array,
        const index_type * const restrict pdim,
        GFC_LOGICAL_4 * mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  GFC_REAL_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;
 
 
  if (*mask)
    {
      maxval_r8 (retarray, array, pdim);
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
 
  for (n = 0; n < dim; n++)
    {
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 
      if (extent[n] <= 0)
        extent[n] = 0;
    }
 
  for (n = dim; n < rank; n++)
    {
      extent[n] =
        GFC_DESCRIPTOR_EXTENT(array,n + 1);
 
      if (extent[n] <= 0)
        extent[n] = 0;
    }
 
  if (retarray->data == NULL)
    {
      size_t alloc_size, str;
 
      for (n = 0; n < rank; n++)
        {
          if (n == 0)
            str = 1;
          else
            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 
          GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 
        }
 
      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 
      alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
                   * extent[rank-1];
 
      if (alloc_size == 0)
        {
          /* Make sure we have a zero-sized array.  */
          GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
          return;
        }
      else
        retarray->data = internal_malloc_size (alloc_size);
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
        runtime_error ("rank of return array incorrect in"
                       " MAXVAL intrinsic: is %ld, should be %ld",
                       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
                       (long int) rank);
 
      if (unlikely (compile_options.bounds_check))
        {
          for (n=0; n < rank; n++)
            {
              index_type ret_extent;
 
              ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
              if (extent[n] != ret_extent)
                runtime_error ("Incorrect extent in return value of"
                               " MAXVAL intrinsic in dimension %ld:"
                               " is %ld, should be %ld", (long int) n + 1,
                               (long int) ret_extent, (long int) extent[n]);
            }
        }
    }
 
  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
    }
 
  dest = retarray->data;
 
  while(1)
    {
      *dest = -GFC_REAL_8_HUGE;
      count[0]++;
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          count[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          dest -= dstride[n] * extent[n];
          n++;
          if (n == rank)
            return;
          else
            {
              count[n]++;
              dest += dstride[n];
            }
        }
    }
}
 
#endif

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [generated/] [maxval_r8.c] - Blame information for rev 860

Line No.	Rev	Author	Line
1	733	jeremybenn	`/* Implementation of the MAXVAL intrinsic`
2			`Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc.`
3			`Contributed by Paul Brook <paul@nowt.org>`
4
5			`This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version.`
11
12			`Libgfortran is distributed in the hope that it will be useful,`
13			`but WITHOUT ANY WARRANTY; without even the implied warranty of`
14			`MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
15			`GNU General Public License for more details.`
16
17			`Under Section 7 of GPL version 3, you are granted additional`
18			`permissions described in the GCC Runtime Library Exception, version`
19			`3.1, as published by the Free Software Foundation.`
20
21			`You should have received a copy of the GNU General Public License and`
22			`a copy of the GCC Runtime Library Exception along with this program;`
23			`see the files COPYING3 and COPYING.RUNTIME respectively. If not, see`
24			`<http://www.gnu.org/licenses/>. */`
25
26			`#include "libgfortran.h"`
27			`#include <stdlib.h>`
28			`#include <assert.h>`
29
30
31			`#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8)`
32
33
34			`extern void maxval_r8 (gfc_array_r8 * const restrict,`
35			`gfc_array_r8 * const restrict, const index_type * const restrict);`
36			`export_proto(maxval_r8);`
37
38			`void`
39			`maxval_r8 (gfc_array_r8 * const restrict retarray,`
40			`gfc_array_r8 * const restrict array,`
41			`const index_type * const restrict pdim)`
42			`{`
43			`index_type count[GFC_MAX_DIMENSIONS];`
44			`index_type extent[GFC_MAX_DIMENSIONS];`
45			`index_type sstride[GFC_MAX_DIMENSIONS];`
46			`index_type dstride[GFC_MAX_DIMENSIONS];`
47			`const GFC_REAL_8 * restrict base;`
48			`GFC_REAL_8 * restrict dest;`
49			`index_type rank;`
50			`index_type n;`
51			`index_type len;`
52			`index_type delta;`
53			`index_type dim;`
54			`int continue_loop;`
55
56			`/* Make dim zero based to avoid confusion. */`
57			`dim = (*pdim) - 1;`
58			`rank = GFC_DESCRIPTOR_RANK (array) - 1;`
59
60			`len = GFC_DESCRIPTOR_EXTENT(array,dim);`
61			`if (len < 0)`
62			`len = 0;`
63			`delta = GFC_DESCRIPTOR_STRIDE(array,dim);`
64
65			`for (n = 0; n < dim; n++)`
66			`{`
67			`sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);`
68			`extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);`
69
70			`if (extent[n] < 0)`
71			`extent[n] = 0;`
72			`}`
73			`for (n = dim; n < rank; n++)`
74			`{`
75			`sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);`
76			`extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);`
77
78			`if (extent[n] < 0)`
79			`extent[n] = 0;`
80			`}`
81
82			`if (retarray->data == NULL)`
83			`{`
84			`size_t alloc_size, str;`
85
86			`for (n = 0; n < rank; n++)`
87			`{`
88			`if (n == 0)`
89			`str = 1;`
90			`else`
91			`str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];`
92
93			`GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);`
94
95			`}`
96
97			`retarray->offset = 0;`
98			`retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;`
99
100			`alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)`
101			`* extent[rank-1];`
102
103			`retarray->data = internal_malloc_size (alloc_size);`
104			`if (alloc_size == 0)`
105			`{`
106			`/* Make sure we have a zero-sized array. */`
107			`GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);`
108			`return;`
109
110			`}`
111			`}`
112			`else`
113			`{`
114			`if (rank != GFC_DESCRIPTOR_RANK (retarray))`
115			`runtime_error ("rank of return array incorrect in"`
116			`" MAXVAL intrinsic: is %ld, should be %ld",`
117			`(long int) (GFC_DESCRIPTOR_RANK (retarray)),`
118			`(long int) rank);`
119
120			`if (unlikely (compile_options.bounds_check))`
121			`bounds_ifunction_return ((array_t *) retarray, extent,`
122			`"return value", "MAXVAL");`
123			`}`
124
125			`for (n = 0; n < rank; n++)`
126			`{`
127			`count[n] = 0;`
128			`dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);`
129			`if (extent[n] <= 0)`
130			`return;`
131			`}`
132
133			`base = array->data;`
134			`dest = retarray->data;`
135
136			`continue_loop = 1;`
137			`while (continue_loop)`
138			`{`
139			`const GFC_REAL_8 * restrict src;`
140			`GFC_REAL_8 result;`
141			`src = base;`
142			`{`
143
144			`#if defined (GFC_REAL_8_INFINITY)`
145			`result = -GFC_REAL_8_INFINITY;`
146			`#else`
147			`result = -GFC_REAL_8_HUGE;`
148			`#endif`
149			`if (len <= 0)`
150			`*dest = -GFC_REAL_8_HUGE;`
151			`else`
152			`{`
153			`for (n = 0; n < len; n++, src += delta)`
154			`{`
155
156			`#if defined (GFC_REAL_8_QUIET_NAN)`
157			`if (*src >= result)`
158			`break;`
159			`}`
160			`if (unlikely (n >= len))`
161			`result = GFC_REAL_8_QUIET_NAN;`
162			`else for (; n < len; n++, src += delta)`
163			`{`
164			`#endif`
165			`if (*src > result)`
166			`result = *src;`
167			`}`
168
169			`*dest = result;`
170			`}`
171			`}`
172			`/* Advance to the next element. */`
173			`count[0]++;`
174			`base += sstride[0];`
175			`dest += dstride[0];`
176			`n = 0;`
177			`while (count[n] == extent[n])`
178			`{`
179			`/* When we get to the end of a dimension, reset it and increment`
180			`the next dimension. */`
181			`count[n] = 0;`
182			`/* We could precalculate these products, but this is a less`
183			`frequently used path so probably not worth it. */`
184			`base -= sstride[n] * extent[n];`
185			`dest -= dstride[n] * extent[n];`
186			`n++;`
187			`if (n == rank)`
188			`{`
189			`/* Break out of the look. */`
190			`continue_loop = 0;`
191			`break;`
192			`}`
193			`else`
194			`{`
195			`count[n]++;`
196			`base += sstride[n];`
197			`dest += dstride[n];`
198			`}`
199			`}`
200			`}`
201			`}`
202
203
204			`extern void mmaxval_r8 (gfc_array_r8 * const restrict,`
205			`gfc_array_r8 * const restrict, const index_type * const restrict,`
206			`gfc_array_l1 * const restrict);`
207			`export_proto(mmaxval_r8);`
208
209			`void`
210			`mmaxval_r8 (gfc_array_r8 * const restrict retarray,`
211			`gfc_array_r8 * const restrict array,`
212			`const index_type * const restrict pdim,`
213			`gfc_array_l1 * const restrict mask)`
214			`{`
215			`index_type count[GFC_MAX_DIMENSIONS];`
216			`index_type extent[GFC_MAX_DIMENSIONS];`
217			`index_type sstride[GFC_MAX_DIMENSIONS];`
218			`index_type dstride[GFC_MAX_DIMENSIONS];`
219			`index_type mstride[GFC_MAX_DIMENSIONS];`
220			`GFC_REAL_8 * restrict dest;`
221			`const GFC_REAL_8 * restrict base;`
222			`const GFC_LOGICAL_1 * restrict mbase;`
223			`int rank;`
224			`int dim;`
225			`index_type n;`
226			`index_type len;`
227			`index_type delta;`
228			`index_type mdelta;`
229			`int mask_kind;`
230
231			`dim = (*pdim) - 1;`
232			`rank = GFC_DESCRIPTOR_RANK (array) - 1;`
233
234			`len = GFC_DESCRIPTOR_EXTENT(array,dim);`
235			`if (len <= 0)`
236			`return;`
237
238			`mbase = mask->data;`
239
240			`mask_kind = GFC_DESCRIPTOR_SIZE (mask);`
241
242			`if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8`
243			`#ifdef HAVE_GFC_LOGICAL_16`
244			`\|\| mask_kind == 16`
245			`#endif`
246			`)`
247			`mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);`
248			`else`
249			`runtime_error ("Funny sized logical array");`
250
251			`delta = GFC_DESCRIPTOR_STRIDE(array,dim);`
252			`mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);`
253
254			`for (n = 0; n < dim; n++)`
255			`{`
256			`sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);`
257			`mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);`
258			`extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);`
259
260			`if (extent[n] < 0)`
261			`extent[n] = 0;`
262
263			`}`
264			`for (n = dim; n < rank; n++)`
265			`{`
266			`sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);`
267			`mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);`
268			`extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);`
269
270			`if (extent[n] < 0)`
271			`extent[n] = 0;`
272			`}`
273
274			`if (retarray->data == NULL)`
275			`{`
276			`size_t alloc_size, str;`
277
278			`for (n = 0; n < rank; n++)`
279			`{`
280			`if (n == 0)`
281			`str = 1;`
282			`else`
283			`str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];`
284
285			`GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);`
286
287			`}`
288
289			`alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)`
290			`* extent[rank-1];`
291
292			`retarray->offset = 0;`
293			`retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;`
294
295			`if (alloc_size == 0)`
296			`{`
297			`/* Make sure we have a zero-sized array. */`
298			`GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);`
299			`return;`
300			`}`
301			`else`
302			`retarray->data = internal_malloc_size (alloc_size);`
303
304			`}`
305			`else`
306			`{`
307			`if (rank != GFC_DESCRIPTOR_RANK (retarray))`
308			`runtime_error ("rank of return array incorrect in MAXVAL intrinsic");`
309
310			`if (unlikely (compile_options.bounds_check))`
311			`{`
312			`bounds_ifunction_return ((array_t *) retarray, extent,`
313			`"return value", "MAXVAL");`
314			`bounds_equal_extents ((array_t ) mask, (array_t ) array,`
315			`"MASK argument", "MAXVAL");`
316			`}`
317			`}`
318
319			`for (n = 0; n < rank; n++)`
320			`{`
321			`count[n] = 0;`
322			`dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);`
323			`if (extent[n] <= 0)`
324			`return;`
325			`}`
326
327			`dest = retarray->data;`
328			`base = array->data;`
329
330			`while (base)`
331			`{`
332			`const GFC_REAL_8 * restrict src;`
333			`const GFC_LOGICAL_1 * restrict msrc;`
334			`GFC_REAL_8 result;`
335			`src = base;`
336			`msrc = mbase;`
337			`{`
338
339			`#if defined (GFC_REAL_8_INFINITY)`
340			`result = -GFC_REAL_8_INFINITY;`
341			`#else`
342			`result = -GFC_REAL_8_HUGE;`
343			`#endif`
344			`#if defined (GFC_REAL_8_QUIET_NAN)`
345			`int non_empty_p = 0;`
346			`#endif`
347			`if (len <= 0)`
348			`*dest = -GFC_REAL_8_HUGE;`
349			`else`
350			`{`
351			`for (n = 0; n < len; n++, src += delta, msrc += mdelta)`
352			`{`
353
354			`#if defined (GFC_REAL_8_INFINITY) \|\| defined (GFC_REAL_8_QUIET_NAN)`
355			`if (*msrc)`
356			`{`
357			`#if defined (GFC_REAL_8_QUIET_NAN)`
358			`non_empty_p = 1;`
359			`if (*src >= result)`
360			`#endif`
361			`break;`
362			`}`
363			`}`
364			`if (unlikely (n >= len))`
365			`{`
366			`#if defined (GFC_REAL_8_QUIET_NAN)`
367			`result = non_empty_p ? GFC_REAL_8_QUIET_NAN : -GFC_REAL_8_HUGE;`
368			`#else`
369			`result = -GFC_REAL_8_HUGE;`
370			`#endif`
371			`}`
372			`else for (; n < len; n++, src += delta, msrc += mdelta)`
373			`{`
374			`#endif`
375			`if (msrc && src > result)`
376			`result = *src;`
377			`}`
378			`*dest = result;`
379			`}`
380			`}`
381			`/* Advance to the next element. */`
382			`count[0]++;`
383			`base += sstride[0];`
384			`mbase += mstride[0];`
385			`dest += dstride[0];`
386			`n = 0;`
387			`while (count[n] == extent[n])`
388			`{`
389			`/* When we get to the end of a dimension, reset it and increment`
390			`the next dimension. */`
391			`count[n] = 0;`
392			`/* We could precalculate these products, but this is a less`
393			`frequently used path so probably not worth it. */`
394			`base -= sstride[n] * extent[n];`
395			`mbase -= mstride[n] * extent[n];`
396			`dest -= dstride[n] * extent[n];`
397			`n++;`
398			`if (n == rank)`
399			`{`
400			`/* Break out of the look. */`
401			`base = NULL;`
402			`break;`
403			`}`
404			`else`
405			`{`
406			`count[n]++;`
407			`base += sstride[n];`
408			`mbase += mstride[n];`
409			`dest += dstride[n];`
410			`}`
411			`}`
412			`}`
413			`}`
414
415
416			`extern void smaxval_r8 (gfc_array_r8 * const restrict,`
417			`gfc_array_r8 * const restrict, const index_type * const restrict,`
418			`GFC_LOGICAL_4 *);`
419			`export_proto(smaxval_r8);`
420
421			`void`
422			`smaxval_r8 (gfc_array_r8 * const restrict retarray,`
423			`gfc_array_r8 * const restrict array,`
424			`const index_type * const restrict pdim,`
425			`GFC_LOGICAL_4 * mask)`
426			`{`
427			`index_type count[GFC_MAX_DIMENSIONS];`
428			`index_type extent[GFC_MAX_DIMENSIONS];`
429			`index_type dstride[GFC_MAX_DIMENSIONS];`
430			`GFC_REAL_8 * restrict dest;`
431			`index_type rank;`
432			`index_type n;`
433			`index_type dim;`
434
435
436			`if (*mask)`
437			`{`
438			`maxval_r8 (retarray, array, pdim);`
439			`return;`
440			`}`
441			`/* Make dim zero based to avoid confusion. */`
442			`dim = (*pdim) - 1;`
443			`rank = GFC_DESCRIPTOR_RANK (array) - 1;`
444
445			`for (n = 0; n < dim; n++)`
446			`{`
447			`extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);`
448
449			`if (extent[n] <= 0)`
450			`extent[n] = 0;`
451			`}`
452
453			`for (n = dim; n < rank; n++)`
454			`{`
455			`extent[n] =`
456			`GFC_DESCRIPTOR_EXTENT(array,n + 1);`
457
458			`if (extent[n] <= 0)`
459			`extent[n] = 0;`
460			`}`
461
462			`if (retarray->data == NULL)`
463			`{`
464			`size_t alloc_size, str;`
465
466			`for (n = 0; n < rank; n++)`
467			`{`
468			`if (n == 0)`
469			`str = 1;`
470			`else`
471			`str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];`
472
473			`GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);`
474
475			`}`
476
477			`retarray->offset = 0;`
478			`retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;`
479
480			`alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)`
481			`* extent[rank-1];`
482
483			`if (alloc_size == 0)`
484			`{`
485			`/* Make sure we have a zero-sized array. */`
486			`GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);`
487			`return;`
488			`}`
489			`else`
490			`retarray->data = internal_malloc_size (alloc_size);`
491			`}`
492			`else`
493			`{`
494			`if (rank != GFC_DESCRIPTOR_RANK (retarray))`
495			`runtime_error ("rank of return array incorrect in"`
496			`" MAXVAL intrinsic: is %ld, should be %ld",`
497			`(long int) (GFC_DESCRIPTOR_RANK (retarray)),`
498			`(long int) rank);`
499
500			`if (unlikely (compile_options.bounds_check))`
501			`{`
502			`for (n=0; n < rank; n++)`
503			`{`
504			`index_type ret_extent;`
505
506			`ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);`
507			`if (extent[n] != ret_extent)`
508			`runtime_error ("Incorrect extent in return value of"`
509			`" MAXVAL intrinsic in dimension %ld:"`
510			`" is %ld, should be %ld", (long int) n + 1,`
511			`(long int) ret_extent, (long int) extent[n]);`
512			`}`
513			`}`
514			`}`
515
516			`for (n = 0; n < rank; n++)`
517			`{`
518			`count[n] = 0;`
519			`dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);`
520			`}`
521
522			`dest = retarray->data;`
523
524			`while(1)`
525			`{`
526			`*dest = -GFC_REAL_8_HUGE;`
527			`count[0]++;`
528			`dest += dstride[0];`
529			`n = 0;`
530			`while (count[n] == extent[n])`
531			`{`
532			`/* When we get to the end of a dimension, reset it and increment`
533			`the next dimension. */`
534			`count[n] = 0;`
535			`/* We could precalculate these products, but this is a less`
536			`frequently used path so probably not worth it. */`
537			`dest -= dstride[n] * extent[n];`
538			`n++;`
539			`if (n == rank)`
540			`return;`
541			`else`
542			`{`
543			`count[n]++;`
544			`dest += dstride[n];`
545			`}`
546			`}`
547			`}`
548			`}`
549
550			`#endif`