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

Subversion Repositories openrisc

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

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


/* Implementation of the MAXLOC 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>
#include <limits.h>
 
 
#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4)
 
 
extern void maxloc1_4_r8 (gfc_array_i4 * const restrict,
        gfc_array_r8 * const restrict, const index_type * const restrict);
export_proto(maxloc1_4_r8);
 
void
maxloc1_4_r8 (gfc_array_i4 * 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_INTEGER_4 * 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_INTEGER_4) * 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"
                       " MAXLOC 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", "MAXLOC");
    }
 
  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_INTEGER_4 result;
      src = base;
      {
 
        GFC_REAL_8 maxval;
#if defined (GFC_REAL_8_INFINITY)
        maxval = -GFC_REAL_8_INFINITY;
#else
        maxval = -GFC_REAL_8_HUGE;
#endif
        result = 1;
        if (len <= 0)
          *dest = 0;
        else
          {
            for (n = 0; n < len; n++, src += delta)
              {
 
#if defined (GFC_REAL_8_QUIET_NAN)
                if (*src >= maxval)
                  {
                    maxval = *src;
                    result = (GFC_INTEGER_4)n + 1;
                    break;
                  }
              }
            for (; n < len; n++, src += delta)
              {
#endif
                if (*src > maxval)
                  {
                    maxval = *src;
                    result = (GFC_INTEGER_4)n + 1;
                  }
              }
 
            *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 mmaxloc1_4_r8 (gfc_array_i4 * const restrict,
        gfc_array_r8 * const restrict, const index_type * const restrict,
        gfc_array_l1 * const restrict);
export_proto(mmaxloc1_4_r8);
 
void
mmaxloc1_4_r8 (gfc_array_i4 * 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_INTEGER_4 * 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_INTEGER_4) * 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 MAXLOC intrinsic");
 
      if (unlikely (compile_options.bounds_check))
        {
          bounds_ifunction_return ((array_t *) retarray, extent,
                                   "return value", "MAXLOC");
          bounds_equal_extents ((array_t *) mask, (array_t *) array,
                                "MASK argument", "MAXLOC");
        }
    }
 
  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_INTEGER_4 result;
      src = base;
      msrc = mbase;
      {
 
        GFC_REAL_8 maxval;
#if defined (GFC_REAL_8_INFINITY)
        maxval = -GFC_REAL_8_INFINITY;
#else
        maxval = -GFC_REAL_8_HUGE;
#endif
#if defined (GFC_REAL_8_QUIET_NAN)
        GFC_INTEGER_4 result2 = 0;
#endif
        result = 0;
        if (len <= 0)
          *dest = 0;
        else
          {
            for (n = 0; n < len; n++, src += delta, msrc += mdelta)
              {
 
                if (*msrc)
                  {
#if defined (GFC_REAL_8_QUIET_NAN)
                    if (!result2)
                      result2 = (GFC_INTEGER_4)n + 1;
                    if (*src >= maxval)
#endif
                      {
                        maxval = *src;
                        result = (GFC_INTEGER_4)n + 1;
                        break;
                      }
                  }
              }
#if defined (GFC_REAL_8_QUIET_NAN)
            if (unlikely (n >= len))
              result = result2;
            else
#endif
            for (; n < len; n++, src += delta, msrc += mdelta)
              {
                if (*msrc && *src > maxval)
                  {
                    maxval = *src;
                    result = (GFC_INTEGER_4)n + 1;
                  }
              }
            *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 smaxloc1_4_r8 (gfc_array_i4 * const restrict,
        gfc_array_r8 * const restrict, const index_type * const restrict,
        GFC_LOGICAL_4 *);
export_proto(smaxloc1_4_r8);
 
void
smaxloc1_4_r8 (gfc_array_i4 * 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_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;
 
 
  if (*mask)
    {
      maxloc1_4_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_INTEGER_4) * 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"
                       " MAXLOC 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"
                               " MAXLOC 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 = 0;
      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/] [maxloc1_4_r8.c] - Blame information for rev 775

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