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

/* 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_16) && defined (HAVE_GFC_INTEGER_8)


extern void maxloc1_8_r16 (gfc_array_i8 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict);
export_proto(maxloc1_8_r16);

void
maxloc1_8_r16 (gfc_array_i8 * 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_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_INTEGER_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"
		       " 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)
	len = 0;
    }

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

  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_REAL_16 * restrict src;
      GFC_INTEGER_8 result;
      src = base;
      {

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

#if defined (GFC_REAL_16_QUIET_NAN)
		if (*src >= maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_8)n + 1;
		    break;
		  }
	      }
	    for (; n < len; n++, src += delta)
	      {
#endif
		if (*src > maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_8)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_8_r16 (gfc_array_i8 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxloc1_8_r16);

void
mmaxloc1_8_r16 (gfc_array_i8 * 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_8 * 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 = 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_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 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_16 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_8 result;
      src = base;
      msrc = mbase;
      {

	GFC_REAL_16 maxval;
#if defined (GFC_REAL_16_INFINITY)
	maxval = -GFC_REAL_16_INFINITY;
#else
	maxval = -GFC_REAL_16_HUGE;
#endif
#if defined (GFC_REAL_16_QUIET_NAN)
	GFC_INTEGER_8 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_16_QUIET_NAN)
		    if (!result2)
		      result2 = (GFC_INTEGER_8)n + 1;
		    if (*src >= maxval)
#endif
		      {
			maxval = *src;
			result = (GFC_INTEGER_8)n + 1;
			break;
		      }
		  }
	      }
#if defined (GFC_REAL_16_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_8)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_8_r16 (gfc_array_i8 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxloc1_8_r16);

void
smaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r16 * 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_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


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