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

/* Implementation of the SUM intrinsic
   Copyright (C) 2002-2015 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

This file is part of the GNU Fortran 95 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_REAL_10) && defined (HAVE_GFC_REAL_10)


extern void sum_r10 (gfc_array_r10 * const restrict, 
	gfc_array_r10 * const restrict, const index_type * const restrict);
export_proto(sum_r10);

void
sum_r10 (gfc_array_r10 * const restrict retarray, 
	gfc_array_r10 * const restrict array, 
	const index_type * const restrict pdim)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_REAL_10 * restrict base;
  GFC_REAL_10 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

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

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

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

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

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

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

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

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

	}

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

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

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
      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"
		       " SUM 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", "SUM");
    }

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

  result = 0;
	if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

  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 msum_r10 (gfc_array_r10 * const restrict, 
	gfc_array_r10 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(msum_r10);

void
msum_r10 (gfc_array_r10 * const restrict retarray, 
	gfc_array_r10 * 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_REAL_10 * restrict dest;
  const GFC_REAL_10 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

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

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

  mbase = mask->base_addr;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

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

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

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

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

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

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

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

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

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

	}

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

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

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

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

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

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

  result = 0;
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

  if (*msrc)
    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 ssum_r10 (gfc_array_r10 * const restrict, 
	gfc_array_r10 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(ssum_r10);

void
ssum_r10 (gfc_array_r10 * const restrict retarray, 
	gfc_array_r10 * 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_REAL_10 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      sum_r10 (retarray, array, pdim);
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

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

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

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

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

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

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

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

	}

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

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

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " SUM 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"
			       " SUM 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 SUM intrinsic
5624e564	2	Copyright (C) 2002-2015 Free Software Foundation, Inc.
644cb69f FXC	3	Contributed by Paul Brook <paul@nowt.org>
	4
	5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	6
	7	Libgfortran is free software; you can redistribute it and/or
	8	modify it under the terms of the GNU General Public
	9	License as published by the Free Software Foundation; either
748086b7	10	version 3 of the License, or (at your option) any later version.
644cb69f FXC	11
	12	Libgfortran is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
	16
748086b7 JJ	17	Under Section 7 of GPL version 3, you are granted additional
	18	permissions described in the GCC Runtime Library Exception, version
	19	3.1, as published by the Free Software Foundation.
	20
	21	You should have received a copy of the GNU General Public License and
	22	a copy of the GCC Runtime Library Exception along with this program;
	23	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	24	<http://www.gnu.org/licenses/>. */
644cb69f	25
36ae8a61	26	#include "libgfortran.h"
644cb69f FXC	27	#include <stdlib.h>
644cb69f FXC	28	#include <assert.h>
644cb69f FXC	29
	30
	31	#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10)
	32
	33
64acfd99 JB	34	extern void sum_r10 (gfc_array_r10 * const restrict,
64acfd99 JB	35	gfc_array_r10 * const restrict, const index_type * const restrict);
644cb69f FXC	36	export_proto(sum_r10);
	37
	38	void
64acfd99 JB	39	sum_r10 (gfc_array_r10 * const restrict retarray,
	40	gfc_array_r10 * const restrict array,
	41	const index_type * const restrict pdim)
644cb69f FXC	42	{
	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_REAL_10 * restrict base;
64acfd99 JB	48	GFC_REAL_10 * restrict dest;
644cb69f FXC	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;
644cb69f FXC	55
	56	/* Make dim zero based to avoid confusion. */
	57	dim = (*pdim) - 1;
	58	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	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);
644cb69f FXC	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;
644cb69f FXC	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;
644cb69f FXC	80	}
644cb69f FXC	81
21d1335b	82	if (retarray->base_addr == NULL)
644cb69f	83	{
dfb55fdc	84	size_t alloc_size, str;
80ee04b9	85
644cb69f	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	}
644cb69f	96
644cb69f FXC	97	retarray->offset = 0;
644cb69f FXC	98	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9	99
92e6f3a4	100	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
80ee04b9	101
92e6f3a4	102	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
80ee04b9 TK	103	if (alloc_size == 0)
	104	{
	105	/* Make sure we have a zero-sized array. */
dfb55fdc	106	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9	107	return;
dfb55fdc	108
80ee04b9	109	}
644cb69f FXC	110	}
	111	else
	112	{
644cb69f	113	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8	114	runtime_error ("rank of return array incorrect in"
ccacefc7 TK	115	" SUM intrinsic: is %ld, should be %ld",
	116	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	117	(long int) rank);
fd6590f8	118
9731c4a3	119	if (unlikely (compile_options.bounds_check))
16bff921 TK	120	bounds_ifunction_return ((array_t *) retarray, extent,
16bff921 TK	121	"return value", "SUM");
644cb69f FXC	122	}
	123
	124	for (n = 0; n < rank; n++)
	125	{
	126	count[n] = 0;
dfb55fdc	127	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
644cb69f	128	if (extent[n] <= 0)
facc1285	129	return;
644cb69f FXC	130	}
644cb69f FXC	131
21d1335b TB	132	base = array->base_addr;
21d1335b TB	133	dest = retarray->base_addr;
644cb69f	134
da96f5ab TK	135	continue_loop = 1;
da96f5ab TK	136	while (continue_loop)
644cb69f	137	{
64acfd99	138	const GFC_REAL_10 * restrict src;
644cb69f FXC	139	GFC_REAL_10 result;
	140	src = base;
	141	{
	142
	143	result = 0;
80927a56	144	if (len <= 0)
644cb69f FXC	145	*dest = 0;
	146	else
	147	{
	148	for (n = 0; n < len; n++, src += delta)
	149	{
	150
	151	result += *src;
80927a56	152	}
0cd0559e	153
644cb69f FXC	154	*dest = result;
	155	}
	156	}
	157	/* Advance to the next element. */
	158	count[0]++;
	159	base += sstride[0];
	160	dest += dstride[0];
	161	n = 0;
	162	while (count[n] == extent[n])
80927a56 JJ	163	{
	164	/* When we get to the end of a dimension, reset it and increment
	165	the next dimension. */
	166	count[n] = 0;
	167	/* We could precalculate these products, but this is a less
	168	frequently used path so probably not worth it. */
	169	base -= sstride[n] * extent[n];
	170	dest -= dstride[n] * extent[n];
	171	n++;
	172	if (n == rank)
	173	{
	174	/* Break out of the look. */
da96f5ab TK	175	continue_loop = 0;
da96f5ab TK	176	break;
80927a56 JJ	177	}
	178	else
	179	{
	180	count[n]++;
	181	base += sstride[n];
	182	dest += dstride[n];
	183	}
	184	}
644cb69f FXC	185	}
	186	}
	187
	188
64acfd99 JB	189	extern void msum_r10 (gfc_array_r10 * const restrict,
64acfd99 JB	190	gfc_array_r10 * const restrict, const index_type * const restrict,
28dc6b33	191	gfc_array_l1 * const restrict);
644cb69f FXC	192	export_proto(msum_r10);
	193
	194	void
64acfd99 JB	195	msum_r10 (gfc_array_r10 * const restrict retarray,
	196	gfc_array_r10 * const restrict array,
	197	const index_type * const restrict pdim,
28dc6b33	198	gfc_array_l1 * const restrict mask)
644cb69f FXC	199	{
	200	index_type count[GFC_MAX_DIMENSIONS];
	201	index_type extent[GFC_MAX_DIMENSIONS];
	202	index_type sstride[GFC_MAX_DIMENSIONS];
	203	index_type dstride[GFC_MAX_DIMENSIONS];
	204	index_type mstride[GFC_MAX_DIMENSIONS];
64acfd99 JB	205	GFC_REAL_10 * restrict dest;
64acfd99 JB	206	const GFC_REAL_10 * restrict base;
28dc6b33	207	const GFC_LOGICAL_1 * restrict mbase;
644cb69f FXC	208	int rank;
	209	int dim;
	210	index_type n;
	211	index_type len;
	212	index_type delta;
	213	index_type mdelta;
28dc6b33	214	int mask_kind;
644cb69f FXC	215
	216	dim = (*pdim) - 1;
	217	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	218
dfb55fdc	219	len = GFC_DESCRIPTOR_EXTENT(array,dim);
644cb69f FXC	220	if (len <= 0)
644cb69f FXC	221	return;
28dc6b33	222
21d1335b	223	mbase = mask->base_addr;
28dc6b33 TK	224
	225	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	226
	227	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	228	#ifdef HAVE_GFC_LOGICAL_16
	229	\|\| mask_kind == 16
	230	#endif
	231	)
	232	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	233	else
	234	runtime_error ("Funny sized logical array");
	235
dfb55fdc TK	236	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
dfb55fdc TK	237	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
644cb69f FXC	238
	239	for (n = 0; n < dim; n++)
	240	{
dfb55fdc TK	241	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	242	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	243	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
80ee04b9 TK	244
	245	if (extent[n] < 0)
	246	extent[n] = 0;
	247
644cb69f FXC	248	}
	249	for (n = dim; n < rank; n++)
	250	{
dfb55fdc TK	251	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
	252	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	253	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
80ee04b9 TK	254
	255	if (extent[n] < 0)
	256	extent[n] = 0;
644cb69f FXC	257	}
644cb69f FXC	258
21d1335b	259	if (retarray->base_addr == NULL)
644cb69f	260	{
dfb55fdc	261	size_t alloc_size, str;
80ee04b9	262
644cb69f	263	for (n = 0; n < rank; n++)
80927a56 JJ	264	{
	265	if (n == 0)
	266	str = 1;
	267	else
	268	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	269
	270	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	271
80927a56	272	}
644cb69f	273
92e6f3a4	274	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
80ee04b9	275
644cb69f FXC	276	retarray->offset = 0;
644cb69f FXC	277	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	278
	279	if (alloc_size == 0)
	280	{
	281	/* Make sure we have a zero-sized array. */
dfb55fdc	282	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9 TK	283	return;
	284	}
	285	else
92e6f3a4	286	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
80ee04b9	287
644cb69f FXC	288	}
	289	else
	290	{
644cb69f	291	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8 TK	292	runtime_error ("rank of return array incorrect in SUM intrinsic");
fd6590f8 TK	293
9731c4a3	294	if (unlikely (compile_options.bounds_check))
fd6590f8	295	{
16bff921 TK	296	bounds_ifunction_return ((array_t *) retarray, extent,
	297	"return value", "SUM");
	298	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	299	"MASK argument", "SUM");
fd6590f8	300	}
644cb69f FXC	301	}
	302
	303	for (n = 0; n < rank; n++)
	304	{
	305	count[n] = 0;
dfb55fdc	306	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
644cb69f	307	if (extent[n] <= 0)
80927a56	308	return;
644cb69f FXC	309	}
644cb69f FXC	310
21d1335b TB	311	dest = retarray->base_addr;
21d1335b TB	312	base = array->base_addr;
644cb69f FXC	313
	314	while (base)
	315	{
64acfd99	316	const GFC_REAL_10 * restrict src;
28dc6b33	317	const GFC_LOGICAL_1 * restrict msrc;
644cb69f FXC	318	GFC_REAL_10 result;
	319	src = base;
	320	msrc = mbase;
	321	{
	322
	323	result = 0;
036e1775	324	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
644cb69f	325	{
644cb69f FXC	326
	327	if (*msrc)
	328	result += *src;
644cb69f	329	}
036e1775	330	*dest = result;
644cb69f FXC	331	}
	332	/* Advance to the next element. */
	333	count[0]++;
	334	base += sstride[0];
	335	mbase += mstride[0];
	336	dest += dstride[0];
	337	n = 0;
	338	while (count[n] == extent[n])
80927a56 JJ	339	{
	340	/* When we get to the end of a dimension, reset it and increment
	341	the next dimension. */
	342	count[n] = 0;
	343	/* We could precalculate these products, but this is a less
	344	frequently used path so probably not worth it. */
	345	base -= sstride[n] * extent[n];
	346	mbase -= mstride[n] * extent[n];
	347	dest -= dstride[n] * extent[n];
	348	n++;
	349	if (n == rank)
	350	{
	351	/* Break out of the look. */
	352	base = NULL;
	353	break;
	354	}
	355	else
	356	{
	357	count[n]++;
	358	base += sstride[n];
	359	mbase += mstride[n];
	360	dest += dstride[n];
	361	}
	362	}
644cb69f FXC	363	}
	364	}
	365
97a62038 TK	366
	367	extern void ssum_r10 (gfc_array_r10 * const restrict,
	368	gfc_array_r10 * const restrict, const index_type * const restrict,
	369	GFC_LOGICAL_4 *);
	370	export_proto(ssum_r10);
	371
	372	void
	373	ssum_r10 (gfc_array_r10 * const restrict retarray,
	374	gfc_array_r10 * const restrict array,
	375	const index_type * const restrict pdim,
	376	GFC_LOGICAL_4 * mask)
	377	{
802367d7 TK	378	index_type count[GFC_MAX_DIMENSIONS];
802367d7 TK	379	index_type extent[GFC_MAX_DIMENSIONS];
802367d7 TK	380	index_type dstride[GFC_MAX_DIMENSIONS];
802367d7 TK	381	GFC_REAL_10 * restrict dest;
97a62038 TK	382	index_type rank;
97a62038 TK	383	index_type n;
802367d7 TK	384	index_type dim;
802367d7 TK	385
97a62038 TK	386
	387	if (*mask)
	388	{
	389	sum_r10 (retarray, array, pdim);
	390	return;
	391	}
802367d7 TK	392	/* Make dim zero based to avoid confusion. */
	393	dim = (*pdim) - 1;
	394	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	395
	396	for (n = 0; n < dim; n++)
	397	{
dfb55fdc	398	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
802367d7 TK	399
	400	if (extent[n] <= 0)
	401	extent[n] = 0;
	402	}
	403
	404	for (n = dim; n < rank; n++)
	405	{
802367d7	406	extent[n] =
80927a56	407	GFC_DESCRIPTOR_EXTENT(array,n + 1);
802367d7 TK	408
802367d7 TK	409	if (extent[n] <= 0)
80927a56	410	extent[n] = 0;
802367d7	411	}
97a62038	412
21d1335b	413	if (retarray->base_addr == NULL)
97a62038	414	{
dfb55fdc	415	size_t alloc_size, str;
802367d7 TK	416
802367d7 TK	417	for (n = 0; n < rank; n++)
80927a56 JJ	418	{
	419	if (n == 0)
	420	str = 1;
	421	else
	422	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	423
	424	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	425
80927a56	426	}
802367d7	427
97a62038	428	retarray->offset = 0;
802367d7 TK	429	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
802367d7 TK	430
92e6f3a4	431	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
802367d7 TK	432
	433	if (alloc_size == 0)
	434	{
	435	/* Make sure we have a zero-sized array. */
dfb55fdc	436	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
802367d7 TK	437	return;
	438	}
	439	else
92e6f3a4	440	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_10));
97a62038 TK	441	}
	442	else
	443	{
802367d7 TK	444	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	445	runtime_error ("rank of return array incorrect in"
	446	" SUM intrinsic: is %ld, should be %ld",
	447	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	448	(long int) rank);
	449
9731c4a3	450	if (unlikely (compile_options.bounds_check))
fd6590f8	451	{
802367d7 TK	452	for (n=0; n < rank; n++)
	453	{
	454	index_type ret_extent;
97a62038	455
dfb55fdc	456	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
802367d7 TK	457	if (extent[n] != ret_extent)
	458	runtime_error ("Incorrect extent in return value of"
	459	" SUM intrinsic in dimension %ld:"
	460	" is %ld, should be %ld", (long int) n + 1,
	461	(long int) ret_extent, (long int) extent[n]);
	462	}
fd6590f8 TK	463	}
fd6590f8 TK	464	}
97a62038	465
802367d7 TK	466	for (n = 0; n < rank; n++)
	467	{
	468	count[n] = 0;
dfb55fdc	469	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
802367d7 TK	470	}
802367d7 TK	471
21d1335b	472	dest = retarray->base_addr;
802367d7 TK	473
	474	while(1)
	475	{
	476	*dest = 0;
	477	count[0]++;
	478	dest += dstride[0];
	479	n = 0;
	480	while (count[n] == extent[n])
80927a56	481	{
802367d7	482	/* When we get to the end of a dimension, reset it and increment
80927a56 JJ	483	the next dimension. */
	484	count[n] = 0;
	485	/* We could precalculate these products, but this is a less
	486	frequently used path so probably not worth it. */
	487	dest -= dstride[n] * extent[n];
	488	n++;
	489	if (n == rank)
802367d7	490	return;
80927a56 JJ	491	else
	492	{
	493	count[n]++;
	494	dest += dstride[n];
	495	}
802367d7 TK	496	}
802367d7 TK	497	}
97a62038 TK	498	}
97a62038 TK	499
644cb69f	500	#endif