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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2002-2018 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 <assert.h>


#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4)

#define HAVE_BACK_ARG 1


extern void maxloc1_4_r4 (gfc_array_i4 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
export_proto(maxloc1_4_r4);

void
maxloc1_4_r4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r4 * const restrict array, 
	const index_type * const restrict pdim, GFC_LOGICAL_4 back)
{
  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_4 * 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;

#ifdef HAVE_BACK_ARG
  assert(back == 0);
#endif

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

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 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;
      GFC_DTYPE_COPY_SETRANK(retarray,array,rank);

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

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

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

#if defined (GFC_REAL_4_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 loop.  */
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void mmaxloc1_4_r4 (gfc_array_i4 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
export_proto(mmaxloc1_4_r4);

void
mmaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r4 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
{
  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_4 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

#ifdef HAVE_BACK_ARG
  assert (back == 0);
#endif
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;


  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 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;
      GFC_DTYPE_COPY_SETRANK(retarray,array,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_4));

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

	GFC_REAL_4 maxval;
#if defined (GFC_REAL_4_INFINITY)
	maxval = -GFC_REAL_4_INFINITY;
#else
	maxval = -GFC_REAL_4_HUGE;
#endif
#if defined (GFC_REAL_4_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_4_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_4_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 loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void smaxloc1_4_r4 (gfc_array_i4 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
export_proto(smaxloc1_4_r4);

void
smaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r4 * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
{
  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)
    {
#ifdef HAVE_BACK_ARG
      maxloc1_4_r4 (retarray, array, pdim, back);
#else
      maxloc1_4_r4 (retarray, array, pdim);
#endif
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

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