[thirdparty/gcc.git] / libgfortran / generated / maxloc1_8_r16.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_16) && defined (HAVE_GFC_INTEGER_8)

#define HAVE_BACK_ARG 1


extern void maxloc1_8_r16 (gfc_array_i8 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
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, 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_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.  */
  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;
      retarray->dtype.rank = 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_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
	  {
#if ! defined HAVE_BACK_ARG
	    for (n = 0; n < len; n++, src += delta)
	      {
#endif

#if defined (GFC_REAL_16_QUIET_NAN)
     	     for (n = 0; n < len; n++, src += delta)
	       {
		if (*src >= maxval)
		  {
		    maxval = *src;
		    result = (GFC_INTEGER_8)n + 1;
		    break;
		  }
	      }
#else
	    n = 0;
#endif
	    for (; n < len; n++, src += delta)
	      {
		if (back ? *src >= maxval : *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 loop.  */
	      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, GFC_LOGICAL_4 back);
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, 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_8 * restrict dest;
  const GFC_REAL_16 * 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;

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