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

/* Implementation of the SUM intrinsic
   Copyright (C) 2002-2023 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"


#if defined (HAVE_GFC_COMPLEX_17) && defined (HAVE_GFC_COMPLEX_17)


extern void sum_c17 (gfc_array_c17 * const restrict, 
	gfc_array_c17 * const restrict, const index_type * const restrict);
export_proto(sum_c17);

void
sum_c17 (gfc_array_c17 * const restrict retarray, 
	gfc_array_c17 * 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_COMPLEX_17 * restrict base;
  GFC_COMPLEX_17 * 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 SUM 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_COMPLEX_17));
      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_COMPLEX_17 * restrict src;
      GFC_COMPLEX_17 result;
      src = base;
      {

  result = 0;
	if (len <= 0)
	  *dest = 0;
	else
	  {
#if ! defined HAVE_BACK_ARG
	    for (n = 0; n < len; n++, src += delta)
	      {
#endif

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


extern void msum_c17 (gfc_array_c17 * const restrict, 
	gfc_array_c17 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(msum_c17);

void
msum_c17 (gfc_array_c17 * const restrict retarray, 
	gfc_array_c17 * 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_COMPLEX_17 * restrict dest;
  const GFC_COMPLEX_17 * 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;

  if (mask == NULL)
    {
#ifdef HAVE_BACK_ARG
      sum_c17 (retarray, array, pdim, back);
#else
      sum_c17 (retarray, array, pdim);
#endif
      return;
    }

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


  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in SUM 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;

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

      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_COMPLEX_17 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_COMPLEX_17 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 loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void ssum_c17 (gfc_array_c17 * const restrict, 
	gfc_array_c17 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(ssum_c17);

void
ssum_c17 (gfc_array_c17 * const restrict retarray, 
	gfc_array_c17 * 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_COMPLEX_17 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      sum_c17 (retarray, array, pdim, back);
#else
      sum_c17 (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 SUM 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];

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