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

/* Implementation of the MAXVAL intrinsic
   Copyright (C) 2002-2013 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>


#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8)


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

void
maxval_i8 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i8 * 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_8 * 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 = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
    		   * extent[rank-1];

      retarray->base_addr = xmalloc (alloc_size);
      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;

	}
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " MAXVAL 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", "MAXVAL");
    }

  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_8 * restrict src;
      GFC_INTEGER_8 result;
      src = base;
      {

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

#if defined (GFC_INTEGER_8_QUIET_NAN)
		if (*src >= result)
		  break;
	      }
	    if (unlikely (n >= len))
	      result = GFC_INTEGER_8_QUIET_NAN;
	    else for (; n < len; n++, src += delta)
	      {
#endif
		if (*src > result)
		  result = *src;
	      }
	    
	    *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 mmaxval_i8 (gfc_array_i8 * const restrict, 
	gfc_array_i8 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxval_i8);

void
mmaxval_i8 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i8 * 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_8 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len <= 0)
    return;

  mbase = mask->base_addr;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
  else
    runtime_error ("Funny sized logical array");

  delta = GFC_DESCRIPTOR_STRIDE(array,dim);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;

    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

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

      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmalloc (alloc_size);

    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in MAXVAL intrinsic");

      if (unlikely (compile_options.bounds_check))
	{
	  bounds_ifunction_return ((array_t *) retarray, extent,
				   "return value", "MAXVAL");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
	  			"MASK argument", "MAXVAL");
	}
    }

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

#if defined (GFC_INTEGER_8_INFINITY)
	result = -GFC_INTEGER_8_INFINITY;
#else
	result = (-GFC_INTEGER_8_HUGE-1);
#endif
#if defined (GFC_INTEGER_8_QUIET_NAN)
	int non_empty_p = 0;
#endif
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

#if defined (GFC_INTEGER_8_INFINITY) || defined (GFC_INTEGER_8_QUIET_NAN)
		if (*msrc)
		  {
#if defined (GFC_INTEGER_8_QUIET_NAN)
		    non_empty_p = 1;
		    if (*src >= result)
#endif
		      break;
		  }
	      }
	    if (unlikely (n >= len))
	      {
#if defined (GFC_INTEGER_8_QUIET_NAN)
		result = non_empty_p ? GFC_INTEGER_8_QUIET_NAN : (-GFC_INTEGER_8_HUGE-1);
#else
		result = (-GFC_INTEGER_8_HUGE-1);
#endif
	      }
	    else for (; n < len; n++, src += delta, msrc += mdelta)
	      {
#endif
		if (*msrc && *src > result)
		  result = *src;
	  }
	*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 smaxval_i8 (gfc_array_i8 * const restrict, 
	gfc_array_i8 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxval_i8);

void
smaxval_i8 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i8 * 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)
    {
      maxval_i8 (retarray, array, pdim);
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  for (n = 0; n < dim; n++)
    {
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  for (n = dim; n < rank; n++)
    {
      extent[n] =
	GFC_DESCRIPTOR_EXTENT(array,n + 1);

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

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

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