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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2002-2014 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_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;
  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->base_addr == 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->base_addr = xmalloc (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->base_addr;
  dest = retarray->base_addr;

  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_REAL_16 * restrict src;
      GFC_INTEGER_4 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_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_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 = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len <= 0)
    return;

  mbase = mask->base_addr;

  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->base_addr == 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->base_addr = xmalloc (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->base_addr;
  base = array->base_addr;

  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;
#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_4 result2 = 0;
#endif
	result = 0;
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

		if (*msrc)
		  {
#if defined (GFC_REAL_16_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_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_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 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_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->base_addr == 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->base_addr = xmalloc (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->base_addr;

  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
f0bcf628	2	Copyright (C) 2002-2014 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_4)
	33
	34
64acfd99 JB	35	extern void maxloc1_4_r16 (gfc_array_i4 * const restrict,
64acfd99 JB	36	gfc_array_r16 * const restrict, const index_type * const restrict);
644cb69f FXC	37	export_proto(maxloc1_4_r16);
	38
	39	void
64acfd99 JB	40	maxloc1_4_r16 (gfc_array_i4 * 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_4 * 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	}
644cb69f FXC	82
21d1335b	83	if (retarray->base_addr == NULL)
644cb69f	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_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
80ee04b9 TK	102	* extent[rank-1];
80ee04b9 TK	103
1a0fd3d3	104	retarray->base_addr = xmalloc (alloc_size);
80ee04b9 TK	105	if (alloc_size == 0)
	106	{
	107	/* Make sure we have a zero-sized array. */
dfb55fdc	108	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9	109	return;
dfb55fdc	110
80ee04b9	111	}
644cb69f FXC	112	}
	113	else
	114	{
644cb69f	115	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8	116	runtime_error ("rank of return array incorrect in"
ccacefc7 TK	117	" MAXLOC intrinsic: is %ld, should be %ld",
	118	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	119	(long int) rank);
fd6590f8	120
9731c4a3	121	if (unlikely (compile_options.bounds_check))
16bff921 TK	122	bounds_ifunction_return ((array_t *) retarray, extent,
16bff921 TK	123	"return value", "MAXLOC");
644cb69f FXC	124	}
	125
	126	for (n = 0; n < rank; n++)
	127	{
	128	count[n] = 0;
dfb55fdc	129	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
644cb69f	130	if (extent[n] <= 0)
facc1285	131	return;
644cb69f FXC	132	}
644cb69f FXC	133
21d1335b TB	134	base = array->base_addr;
21d1335b TB	135	dest = retarray->base_addr;
644cb69f	136
da96f5ab TK	137	continue_loop = 1;
da96f5ab TK	138	while (continue_loop)
644cb69f	139	{
64acfd99	140	const GFC_REAL_16 * restrict src;
644cb69f FXC	141	GFC_INTEGER_4 result;
	142	src = base;
	143	{
	144
80927a56 JJ	145	GFC_REAL_16 maxval;
	146	#if defined (GFC_REAL_16_INFINITY)
	147	maxval = -GFC_REAL_16_INFINITY;
	148	#else
	149	maxval = -GFC_REAL_16_HUGE;
	150	#endif
	151	result = 1;
	152	if (len <= 0)
644cb69f FXC	153	*dest = 0;
	154	else
	155	{
	156	for (n = 0; n < len; n++, src += delta)
	157	{
	158
80927a56 JJ	159	#if defined (GFC_REAL_16_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	}
0cd0559e	176
644cb69f FXC	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])
80927a56 JJ	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. */
da96f5ab TK	198	continue_loop = 0;
da96f5ab TK	199	break;
80927a56 JJ	200	}
	201	else
	202	{
	203	count[n]++;
	204	base += sstride[n];
	205	dest += dstride[n];
	206	}
	207	}
644cb69f FXC	208	}
	209	}
	210
	211
64acfd99 JB	212	extern void mmaxloc1_4_r16 (gfc_array_i4 * const restrict,
64acfd99 JB	213	gfc_array_r16 * const restrict, const index_type * const restrict,
28dc6b33	214	gfc_array_l1 * const restrict);
644cb69f FXC	215	export_proto(mmaxloc1_4_r16);
	216
	217	void
64acfd99 JB	218	mmaxloc1_4_r16 (gfc_array_i4 * const restrict retarray,
	219	gfc_array_r16 * const restrict array,
	220	const index_type * const restrict pdim,
28dc6b33	221	gfc_array_l1 * const restrict mask)
644cb69f FXC	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];
64acfd99 JB	228	GFC_INTEGER_4 * restrict dest;
64acfd99 JB	229	const GFC_REAL_16 * restrict base;
28dc6b33	230	const GFC_LOGICAL_1 * restrict mbase;
644cb69f FXC	231	int rank;
	232	int dim;
	233	index_type n;
	234	index_type len;
	235	index_type delta;
	236	index_type mdelta;
28dc6b33	237	int mask_kind;
644cb69f FXC	238
	239	dim = (*pdim) - 1;
	240	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	241
dfb55fdc	242	len = GFC_DESCRIPTOR_EXTENT(array,dim);
644cb69f FXC	243	if (len <= 0)
644cb69f FXC	244	return;
28dc6b33	245
21d1335b	246	mbase = mask->base_addr;
28dc6b33 TK	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
dfb55fdc TK	259	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
dfb55fdc TK	260	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
644cb69f FXC	261
	262	for (n = 0; n < dim; n++)
	263	{
dfb55fdc TK	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);
80ee04b9 TK	267
	268	if (extent[n] < 0)
	269	extent[n] = 0;
	270
644cb69f FXC	271	}
	272	for (n = dim; n < rank; n++)
	273	{
dfb55fdc TK	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);
80ee04b9 TK	277
	278	if (extent[n] < 0)
	279	extent[n] = 0;
644cb69f FXC	280	}
644cb69f FXC	281
21d1335b	282	if (retarray->base_addr == NULL)
644cb69f	283	{
dfb55fdc	284	size_t alloc_size, str;
80ee04b9	285
644cb69f	286	for (n = 0; n < rank; n++)
80927a56 JJ	287	{
	288	if (n == 0)
	289	str = 1;
	290	else
	291	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	292
	293	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	294
80927a56	295	}
644cb69f	296
dfb55fdc	297	alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
80ee04b9 TK	298	* extent[rank-1];
80ee04b9 TK	299
644cb69f FXC	300	retarray->offset = 0;
644cb69f FXC	301	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	302
	303	if (alloc_size == 0)
	304	{
	305	/* Make sure we have a zero-sized array. */
dfb55fdc	306	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9 TK	307	return;
	308	}
	309	else
1a0fd3d3	310	retarray->base_addr = xmalloc (alloc_size);
80ee04b9	311
644cb69f FXC	312	}
	313	else
	314	{
644cb69f	315	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8 TK	316	runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
fd6590f8 TK	317
9731c4a3	318	if (unlikely (compile_options.bounds_check))
fd6590f8	319	{
16bff921 TK	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");
fd6590f8	324	}
644cb69f FXC	325	}
	326
	327	for (n = 0; n < rank; n++)
	328	{
	329	count[n] = 0;
dfb55fdc	330	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
644cb69f	331	if (extent[n] <= 0)
80927a56	332	return;
644cb69f FXC	333	}
644cb69f FXC	334
21d1335b TB	335	dest = retarray->base_addr;
21d1335b TB	336	base = array->base_addr;
644cb69f FXC	337
	338	while (base)
	339	{
64acfd99	340	const GFC_REAL_16 * restrict src;
28dc6b33	341	const GFC_LOGICAL_1 * restrict msrc;
644cb69f FXC	342	GFC_INTEGER_4 result;
	343	src = base;
	344	msrc = mbase;
	345	{
	346
80927a56 JJ	347	GFC_REAL_16 maxval;
	348	#if defined (GFC_REAL_16_INFINITY)
	349	maxval = -GFC_REAL_16_INFINITY;
	350	#else
	351	maxval = -GFC_REAL_16_HUGE;
	352	#endif
	353	#if defined (GFC_REAL_16_QUIET_NAN)
	354	GFC_INTEGER_4 result2 = 0;
	355	#endif
	356	result = 0;
036e1775	357	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
644cb69f	358	{
644cb69f	359
80927a56 JJ	360	if (*msrc)
	361	{
	362	#if defined (GFC_REAL_16_QUIET_NAN)
	363	if (!result2)
	364	result2 = (GFC_INTEGER_4)n + 1;
	365	if (*src >= maxval)
	366	#endif
	367	{
	368	maxval = *src;
	369	result = (GFC_INTEGER_4)n + 1;
	370	break;
	371	}
	372	}
	373	}
	374	#if defined (GFC_REAL_16_QUIET_NAN)
	375	if (unlikely (n >= len))
	376	result = result2;
	377	else
	378	#endif
	379	for (; n < len; n++, src += delta, msrc += mdelta)
	380	{
	381	if (msrc && src > maxval)
	382	{
	383	maxval = *src;
	384	result = (GFC_INTEGER_4)n + 1;
	385	}
644cb69f	386	}
036e1775	387	*dest = result;
644cb69f FXC	388	}
	389	/* Advance to the next element. */
	390	count[0]++;
	391	base += sstride[0];
	392	mbase += mstride[0];
	393	dest += dstride[0];
	394	n = 0;
	395	while (count[n] == extent[n])
80927a56 JJ	396	{
	397	/* When we get to the end of a dimension, reset it and increment
	398	the next dimension. */
	399	count[n] = 0;
	400	/* We could precalculate these products, but this is a less
	401	frequently used path so probably not worth it. */
	402	base -= sstride[n] * extent[n];
	403	mbase -= mstride[n] * extent[n];
	404	dest -= dstride[n] * extent[n];
	405	n++;
	406	if (n == rank)
	407	{
	408	/* Break out of the look. */
	409	base = NULL;
	410	break;
	411	}
	412	else
	413	{
	414	count[n]++;
	415	base += sstride[n];
	416	mbase += mstride[n];
	417	dest += dstride[n];
	418	}
	419	}
644cb69f FXC	420	}
	421	}
	422
97a62038 TK	423
	424	extern void smaxloc1_4_r16 (gfc_array_i4 * const restrict,
	425	gfc_array_r16 * const restrict, const index_type * const restrict,
	426	GFC_LOGICAL_4 *);
	427	export_proto(smaxloc1_4_r16);
	428
	429	void
	430	smaxloc1_4_r16 (gfc_array_i4 * const restrict retarray,
	431	gfc_array_r16 * const restrict array,
	432	const index_type * const restrict pdim,
	433	GFC_LOGICAL_4 * mask)
	434	{
802367d7 TK	435	index_type count[GFC_MAX_DIMENSIONS];
802367d7 TK	436	index_type extent[GFC_MAX_DIMENSIONS];
802367d7 TK	437	index_type dstride[GFC_MAX_DIMENSIONS];
802367d7 TK	438	GFC_INTEGER_4 * restrict dest;
97a62038 TK	439	index_type rank;
97a62038 TK	440	index_type n;
802367d7 TK	441	index_type dim;
802367d7 TK	442
97a62038 TK	443
	444	if (*mask)
	445	{
	446	maxloc1_4_r16 (retarray, array, pdim);
	447	return;
	448	}
802367d7 TK	449	/* Make dim zero based to avoid confusion. */
	450	dim = (*pdim) - 1;
	451	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	452
	453	for (n = 0; n < dim; n++)
	454	{
dfb55fdc	455	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
802367d7 TK	456
	457	if (extent[n] <= 0)
	458	extent[n] = 0;
	459	}
	460
	461	for (n = dim; n < rank; n++)
	462	{
802367d7	463	extent[n] =
80927a56	464	GFC_DESCRIPTOR_EXTENT(array,n + 1);
802367d7 TK	465
802367d7 TK	466	if (extent[n] <= 0)
80927a56	467	extent[n] = 0;
802367d7	468	}
97a62038	469
21d1335b	470	if (retarray->base_addr == NULL)
97a62038	471	{
dfb55fdc	472	size_t alloc_size, str;
802367d7 TK	473
802367d7 TK	474	for (n = 0; n < rank; n++)
80927a56 JJ	475	{
	476	if (n == 0)
	477	str = 1;
	478	else
	479	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	480
	481	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	482
80927a56	483	}
802367d7	484
97a62038	485	retarray->offset = 0;
802367d7 TK	486	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
802367d7 TK	487
dfb55fdc	488	alloc_size = sizeof (GFC_INTEGER_4) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
802367d7 TK	489	* extent[rank-1];
	490
	491	if (alloc_size == 0)
	492	{
	493	/* Make sure we have a zero-sized array. */
dfb55fdc	494	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
802367d7 TK	495	return;
	496	}
	497	else
1a0fd3d3	498	retarray->base_addr = xmalloc (alloc_size);
97a62038 TK	499	}
	500	else
	501	{
802367d7 TK	502	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	503	runtime_error ("rank of return array incorrect in"
	504	" MAXLOC intrinsic: is %ld, should be %ld",
	505	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	506	(long int) rank);
	507
9731c4a3	508	if (unlikely (compile_options.bounds_check))
fd6590f8	509	{
802367d7 TK	510	for (n=0; n < rank; n++)
	511	{
	512	index_type ret_extent;
97a62038	513
dfb55fdc	514	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
802367d7 TK	515	if (extent[n] != ret_extent)
	516	runtime_error ("Incorrect extent in return value of"
	517	" MAXLOC intrinsic in dimension %ld:"
	518	" is %ld, should be %ld", (long int) n + 1,
	519	(long int) ret_extent, (long int) extent[n]);
	520	}
fd6590f8 TK	521	}
fd6590f8 TK	522	}
97a62038	523
802367d7 TK	524	for (n = 0; n < rank; n++)
	525	{
	526	count[n] = 0;
dfb55fdc	527	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
802367d7 TK	528	}
802367d7 TK	529
21d1335b	530	dest = retarray->base_addr;
802367d7 TK	531
	532	while(1)
	533	{
	534	*dest = 0;
	535	count[0]++;
	536	dest += dstride[0];
	537	n = 0;
	538	while (count[n] == extent[n])
80927a56	539	{
802367d7	540	/* When we get to the end of a dimension, reset it and increment
80927a56 JJ	541	the next dimension. */
	542	count[n] = 0;
	543	/* We could precalculate these products, but this is a less
	544	frequently used path so probably not worth it. */
	545	dest -= dstride[n] * extent[n];
	546	n++;
	547	if (n == rank)
802367d7	548	return;
80927a56 JJ	549	else
	550	{
	551	count[n]++;
	552	dest += dstride[n];
	553	}
802367d7 TK	554	}
802367d7 TK	555	}
97a62038 TK	556	}
97a62038 TK	557
644cb69f	558	#endif