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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2002-2016 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_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)


extern void maxloc1_8_i1 (gfc_array_i8 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict);
export_proto(maxloc1_8_i1);

void
maxloc1_8_i1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i1 * 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_INTEGER_1 * 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->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 = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
      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_INTEGER_1 * restrict src;
      GFC_INTEGER_8 result;
      src = base;
      {

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

#if defined (GFC_INTEGER_1_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_i1 (gfc_array_i8 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxloc1_8_i1);

void
mmaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i1 * 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_INTEGER_1 * 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 = 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 = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));

    }
  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_INTEGER_1 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_8 result;
      src = base;
      msrc = mbase;
      {

	GFC_INTEGER_1 maxval;
#if defined (GFC_INTEGER_1_INFINITY)
	maxval = -GFC_INTEGER_1_INFINITY;
#else
	maxval = (-GFC_INTEGER_1_HUGE-1);
#endif
#if defined (GFC_INTEGER_1_QUIET_NAN)
	GFC_INTEGER_8 result2 = 0;
#endif
	result = 0;
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

		if (*msrc)
		  {
#if defined (GFC_INTEGER_1_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_INTEGER_1_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_i1 (gfc_array_i8 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxloc1_8_i1);

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