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

/* Implementation of the SUM intrinsic
   Copyright 2002, 2007, 2009 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_INTEGER_1) && defined (HAVE_GFC_INTEGER_1)


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

void
sum_i1 (gfc_array_i1 * const restrict retarray, 
	gfc_array_i1 * const restrict array, 
	const index_type * const restrict pdim)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_INTEGER_1 * restrict base;
  GFC_INTEGER_1 * 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->data == 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_1) * 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->data = internal_malloc_size (alloc_size);
    }
  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)
	len = 0;
    }

  base = array->data;
  dest = retarray->data;

  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_INTEGER_1 * restrict src;
      GFC_INTEGER_1 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_i1 (gfc_array_i1 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(msum_i1);

void
msum_i1 (gfc_array_i1 * const restrict retarray, 
	gfc_array_i1 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_1 * restrict dest;
  const GFC_INTEGER_1 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

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

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

  mbase = mask->data;

  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->data == 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_1) * 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->data = internal_malloc_size (alloc_size);

    }
  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->data;
  base = array->data;

  while (base)
    {
      const GFC_INTEGER_1 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_1 result;
      src = base;
      msrc = mbase;
      {

  result = 0;
	if (len <= 0)
	  *dest = 0;
	else
	  {
	    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_i1 (gfc_array_i1 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(ssum_i1);

void
ssum_i1 (gfc_array_i1 * const restrict retarray, 
	gfc_array_i1 * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_1 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


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

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

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

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

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

  if (retarray->data == 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_1) * 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->data = internal_malloc_size (alloc_size);
    }
  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->data;

  while(1)
    {
      *dest = 0;
      count[0]++;
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
	{
	  /* When we get to the end of a dimension, reset it and increment
	     the next dimension.  */
	  count[n] = 0;
	  /* We could precalculate these products, but this is a less
	     frequently used path so probably not worth it.  */
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n == rank)
	    return;
	  else
	    {
	      count[n]++;
	      dest += dstride[n];
	    }
      	}
    }
}

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