[thirdparty/gcc.git] / libgfortran / generated / maxloc1_4_r16.c

/* Implementation of the MAXLOC intrinsic
   Copyright 2002 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

This file is part of the GNU Fortran 95 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 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#include "config.h"
#include <stdlib.h>
#include <assert.h>
#include <float.h>
#include <limits.h>
#include "libgfortran.h"


#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4)


extern void maxloc1_4_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict);
export_proto(maxloc1_4_r16);

void
maxloc1_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * 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_16 * restrict base;
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;

  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  delta = array->dim[dim].stride;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

      alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
    		   * extent[rank-1];

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -1;
	  return;
	}
      else
	retarray->data = internal_malloc_size (alloc_size);
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect");
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = retarray->dim[n].stride;
      if (extent[n] <= 0)
        len = 0;
    }

  base = array->data;
  dest = retarray->data;

  while (base)
    {
      const GFC_REAL_16 * restrict src;
      GFC_INTEGER_4 result;
      src = base;
      {

  GFC_REAL_16 maxval;
  maxval = -GFC_REAL_16_HUGE;
  result = 0;
        if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

  if (*src > maxval || !result)
    {
      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.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              dest += dstride[n];
            }
        }
    }
}


extern void mmaxloc1_4_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	gfc_array_l4 * const restrict);
export_proto(mmaxloc1_4_r16);

void
mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l4 * 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_16 * restrict base;
  const GFC_LOGICAL_4 * restrict mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;

  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  if (len <= 0)
    return;
  delta = array->dim[dim].stride;
  mdelta = mask->dim[dim].stride;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

      if (extent[n] < 0)
	extent[n] = 0;

    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      mstride[n] = mask->dim[n + 1].stride;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

      alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
    		   * 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.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -1;
	  return;
	}
      else
	retarray->data = internal_malloc_size (alloc_size);

    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect");
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = retarray->dim[n].stride;
      if (extent[n] <= 0)
        return;
    }

  dest = retarray->data;
  base = array->data;
  mbase = mask->data;

  if (GFC_DESCRIPTOR_SIZE (mask) != 4)
    {
      /* This allows the same loop to be used for all logical types.  */
      assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
      for (n = 0; n < rank; n++)
        mstride[n] <<= 1;
      mdelta <<= 1;
      mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
    }

  while (base)
    {
      const GFC_REAL_16 * restrict src;
      const GFC_LOGICAL_4 * restrict msrc;
      GFC_INTEGER_4 result;
      src = base;
      msrc = mbase;
      {

  GFC_REAL_16 maxval;
  maxval = -GFC_REAL_16_HUGE;
  result = 0;
        if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

  if (*msrc && (*src > maxval || !result))
    {
      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_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxloc1_4_r16);

void
smaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask)
{
  index_type rank;
  index_type n;
  index_type dstride;
  GFC_INTEGER_4 *dest;

  if (*mask)
    {
      maxloc1_4_r16 (retarray, array, pdim);
      return;
    }
    rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->data == NULL)
    {
      retarray->dim[0].lbound = 0;
      retarray->dim[0].ubound = rank-1;
      retarray->dim[0].stride = 1;
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
    }
  else
    {
      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
	runtime_error ("rank of return array does not equal 1");

      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
        runtime_error ("dimension of return array incorrect");
    }

    dstride = retarray->dim[0].stride;
    dest = retarray->data;

    for (n = 0; n < rank; n++)
      dest[n * dstride] = 0 ;
}

#endif
Commit	Line	Data
644cb69f FXC	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_16) && defined (HAVE_GFC_INTEGER_4)
	40
	41
64acfd99 JB	42	extern void maxloc1_4_r16 (gfc_array_i4 * const restrict,
64acfd99 JB	43	gfc_array_r16 * const restrict, const index_type * const restrict);
644cb69f FXC	44	export_proto(maxloc1_4_r16);
	45
	46	void
64acfd99 JB	47	maxloc1_4_r16 (gfc_array_i4 * const restrict retarray,
	48	gfc_array_r16 * const restrict array,
	49	const index_type * const restrict pdim)
644cb69f FXC	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];
64acfd99 JB	55	const GFC_REAL_16 * restrict base;
64acfd99 JB	56	GFC_INTEGER_4 * restrict dest;
644cb69f FXC	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
644cb69f FXC	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;
80ee04b9 TK	74
	75	if (extent[n] < 0)
	76	extent[n] = 0;
644cb69f FXC	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;
80ee04b9 TK	83
	84	if (extent[n] < 0)
	85	extent[n] = 0;
644cb69f FXC	86	}
	87
	88	if (retarray->data == NULL)
	89	{
80ee04b9 TK	90	size_t alloc_size;
80ee04b9 TK	91
644cb69f FXC	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
644cb69f FXC	102	retarray->offset = 0;
644cb69f FXC	103	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	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);
644cb69f FXC	117	}
	118	else
	119	{
644cb69f FXC	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	{
64acfd99	137	const GFC_REAL_16 * restrict src;
644cb69f FXC	138	GFC_INTEGER_4 result;
	139	src = base;
	140	{
	141
	142	GFC_REAL_16 maxval;
	143	maxval = -GFC_REAL_16_HUGE;
a4b9e93e	144	result = 0;
644cb69f FXC	145	if (len <= 0)
	146	*dest = 0;
	147	else
	148	{
	149	for (n = 0; n < len; n++, src += delta)
	150	{
	151
a4b9e93e	152	if (*src > maxval \|\| !result)
644cb69f FXC	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
5d7adf7a	172	frequently used path so probably not worth it. */
644cb69f FXC	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
64acfd99 JB	193	extern void mmaxloc1_4_r16 (gfc_array_i4 * const restrict,
	194	gfc_array_r16 * const restrict, const index_type * const restrict,
	195	gfc_array_l4 * const restrict);
644cb69f FXC	196	export_proto(mmaxloc1_4_r16);
	197
	198	void
64acfd99 JB	199	mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray,
	200	gfc_array_r16 * const restrict array,
	201	const index_type * const restrict pdim,
	202	gfc_array_l4 * const restrict mask)
644cb69f FXC	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];
64acfd99 JB	209	GFC_INTEGER_4 * restrict dest;
	210	const GFC_REAL_16 * restrict base;
	211	const GFC_LOGICAL_4 * restrict mbase;
644cb69f FXC	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
644cb69f FXC	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;
80ee04b9 TK	233
	234	if (extent[n] < 0)
	235	extent[n] = 0;
	236
644cb69f FXC	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;
80ee04b9 TK	244
	245	if (extent[n] < 0)
	246	extent[n] = 0;
644cb69f FXC	247	}
	248
	249	if (retarray->data == NULL)
	250	{
80ee04b9 TK	251	size_t alloc_size;
80ee04b9 TK	252
644cb69f FXC	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
80ee04b9 TK	263	alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
	264	* extent[rank-1];
	265
644cb69f FXC	266	retarray->offset = 0;
644cb69f FXC	267	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	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
644cb69f FXC	279	}
	280	else
	281	{
644cb69f FXC	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	{
64acfd99 JB	310	const GFC_REAL_16 * restrict src;
64acfd99 JB	311	const GFC_LOGICAL_4 * restrict msrc;
644cb69f FXC	312	GFC_INTEGER_4 result;
	313	src = base;
	314	msrc = mbase;
	315	{
	316
	317	GFC_REAL_16 maxval;
	318	maxval = -GFC_REAL_16_HUGE;
a4b9e93e	319	result = 0;
644cb69f FXC	320	if (len <= 0)
	321	*dest = 0;
	322	else
	323	{
	324	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	325	{
	326
a4b9e93e	327	if (msrc && (src > maxval \|\| !result))
644cb69f FXC	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
5d7adf7a	348	frequently used path so probably not worth it. */
644cb69f FXC	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
97a62038 TK	370
	371	extern void smaxloc1_4_r16 (gfc_array_i4 * const restrict,
	372	gfc_array_r16 * const restrict, const index_type * const restrict,
	373	GFC_LOGICAL_4 *);
	374	export_proto(smaxloc1_4_r16);
	375
	376	void
	377	smaxloc1_4_r16 (gfc_array_i4 * const restrict retarray,
	378	gfc_array_r16 * 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_r16 (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");
97a62038 TK	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
644cb69f	421	#endif