[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 <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_l1 * 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_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_16 * 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 = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  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 = array->dim[dim].stride;
  mdelta = mask->dim[dim].stride * mask_kind;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride * mask_kind;
      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 * mask_kind;
      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;

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