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

/* Implementation of the SUM intrinsic
   Copyright (C) 2002-2018 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_INTEGER_16) && defined (HAVE_GFC_INTEGER_16)


extern void sum_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict);
export_proto(sum_i16);

void
sum_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_16 * restrict base;
  GFC_INTEGER_16 * 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;
      GFC_DTYPE_COPY_SETRANK(retarray,array,rank);

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

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
      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_INTEGER_16 * restrict src;
      GFC_INTEGER_16 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_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(msum_i16);

void
msum_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_16 * restrict dest;
  const GFC_INTEGER_16 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

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


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

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

    }
  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_INTEGER_16 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_16 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_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(ssum_i16);

void
ssum_i16 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i16 * 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_16 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
#ifdef HAVE_BACK_ARG
      sum_i16 (retarray, array, pdim, back);
#else
      sum_i16 (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;
      GFC_DTYPE_COPY_SETRANK(retarray,array,rank);

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

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
    }
  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
85ec4feb	2	Copyright (C) 2002-2018 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
	28
	29	#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16)
	30
	31
64acfd99 JB	32	extern void sum_i16 (gfc_array_i16 * const restrict,
64acfd99 JB	33	gfc_array_i16 * const restrict, const index_type * const restrict);
644cb69f FXC	34	export_proto(sum_i16);
	35
	36	void
64acfd99 JB	37	sum_i16 (gfc_array_i16 * const restrict retarray,
	38	gfc_array_i16 * const restrict array,
	39	const index_type * const restrict pdim)
644cb69f FXC	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];
64acfd99 JB	45	const GFC_INTEGER_16 * restrict base;
64acfd99 JB	46	GFC_INTEGER_16 * restrict dest;
644cb69f FXC	47	index_type rank;
	48	index_type n;
	49	index_type len;
	50	index_type delta;
	51	index_type dim;
da96f5ab	52	int continue_loop;
644cb69f FXC	53
644cb69f FXC	54	/* Make dim zero based to avoid confusion. */
644cb69f	55	rank = GFC_DESCRIPTOR_RANK (array) - 1;
cfdf6ff6 TK	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	}
644cb69f	64
dfb55fdc	65	len = GFC_DESCRIPTOR_EXTENT(array,dim);
da96f5ab TK	66	if (len < 0)
da96f5ab TK	67	len = 0;
dfb55fdc	68	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
644cb69f FXC	69
	70	for (n = 0; n < dim; n++)
	71	{
dfb55fdc TK	72	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
dfb55fdc TK	73	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
80ee04b9 TK	74
	75	if (extent[n] < 0)
	76	extent[n] = 0;
644cb69f FXC	77	}
	78	for (n = dim; n < rank; n++)
	79	{
dfb55fdc TK	80	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
dfb55fdc TK	81	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
80ee04b9 TK	82
	83	if (extent[n] < 0)
	84	extent[n] = 0;
644cb69f FXC	85	}
644cb69f FXC	86
21d1335b	87	if (retarray->base_addr == NULL)
644cb69f	88	{
dfb55fdc	89	size_t alloc_size, str;
80ee04b9	90
644cb69f	91	for (n = 0; n < rank; n++)
80927a56 JJ	92	{
80927a56 JJ	93	if (n == 0)
dfb55fdc	94	str = 1;
80927a56 JJ	95	else
80927a56 JJ	96	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	97
	98	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	99
80927a56	100	}
644cb69f	101
644cb69f	102	retarray->offset = 0;
fa3c4d47	103	GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
80ee04b9	104
92e6f3a4	105	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
80ee04b9	106
92e6f3a4	107	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
80ee04b9 TK	108	if (alloc_size == 0)
	109	{
	110	/* Make sure we have a zero-sized array. */
dfb55fdc	111	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9	112	return;
dfb55fdc	113
80ee04b9	114	}
644cb69f FXC	115	}
	116	else
	117	{
644cb69f	118	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8	119	runtime_error ("rank of return array incorrect in"
ccacefc7 TK	120	" SUM intrinsic: is %ld, should be %ld",
	121	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	122	(long int) rank);
fd6590f8	123
9731c4a3	124	if (unlikely (compile_options.bounds_check))
16bff921 TK	125	bounds_ifunction_return ((array_t *) retarray, extent,
16bff921 TK	126	"return value", "SUM");
644cb69f FXC	127	}
	128
	129	for (n = 0; n < rank; n++)
	130	{
	131	count[n] = 0;
dfb55fdc	132	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
644cb69f	133	if (extent[n] <= 0)
facc1285	134	return;
644cb69f FXC	135	}
644cb69f FXC	136
21d1335b TB	137	base = array->base_addr;
21d1335b TB	138	dest = retarray->base_addr;
644cb69f	139
da96f5ab TK	140	continue_loop = 1;
da96f5ab TK	141	while (continue_loop)
644cb69f	142	{
64acfd99	143	const GFC_INTEGER_16 * restrict src;
644cb69f FXC	144	GFC_INTEGER_16 result;
	145	src = base;
	146	{
	147
	148	result = 0;
80927a56	149	if (len <= 0)
644cb69f FXC	150	*dest = 0;
	151	else
	152	{
b573f931	153	#if ! defined HAVE_BACK_ARG
644cb69f FXC	154	for (n = 0; n < len; n++, src += delta)
644cb69f FXC	155	{
b573f931	156	#endif
644cb69f FXC	157
644cb69f FXC	158	result += *src;
80927a56	159	}
0cd0559e	160
644cb69f FXC	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])
80927a56 JJ	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++;
80dd631f	179	if (n >= rank)
80927a56	180	{
80dd631f	181	/* Break out of the loop. */
da96f5ab TK	182	continue_loop = 0;
da96f5ab TK	183	break;
80927a56 JJ	184	}
	185	else
	186	{
	187	count[n]++;
	188	base += sstride[n];
	189	dest += dstride[n];
	190	}
	191	}
644cb69f FXC	192	}
	193	}
	194
	195
64acfd99 JB	196	extern void msum_i16 (gfc_array_i16 * const restrict,
64acfd99 JB	197	gfc_array_i16 * const restrict, const index_type * const restrict,
28dc6b33	198	gfc_array_l1 * const restrict);
644cb69f FXC	199	export_proto(msum_i16);
	200
	201	void
64acfd99 JB	202	msum_i16 (gfc_array_i16 * const restrict retarray,
	203	gfc_array_i16 * const restrict array,
	204	const index_type * const restrict pdim,
28dc6b33	205	gfc_array_l1 * const restrict mask)
644cb69f FXC	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];
64acfd99 JB	212	GFC_INTEGER_16 * restrict dest;
64acfd99 JB	213	const GFC_INTEGER_16 * restrict base;
28dc6b33	214	const GFC_LOGICAL_1 * restrict mbase;
cfdf6ff6 TK	215	index_type rank;
cfdf6ff6 TK	216	index_type dim;
644cb69f FXC	217	index_type n;
	218	index_type len;
	219	index_type delta;
	220	index_type mdelta;
28dc6b33	221	int mask_kind;
644cb69f FXC	222
	223	dim = (*pdim) - 1;
	224	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	225
cfdf6ff6 TK	226
	227	if (unlikely (dim < 0 \|\| dim > rank))
	228	{
	229	runtime_error ("Dim argument incorrect in SUM intrinsic: "
	230	"is %ld, should be between 1 and %ld",
	231	(long int) dim + 1, (long int) rank + 1);
	232	}
	233
dfb55fdc	234	len = GFC_DESCRIPTOR_EXTENT(array,dim);
644cb69f FXC	235	if (len <= 0)
644cb69f FXC	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);
644cb69f FXC	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
644cb69f FXC	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;
644cb69f FXC	272	}
644cb69f FXC	273
21d1335b	274	if (retarray->base_addr == NULL)
644cb69f	275	{
dfb55fdc	276	size_t alloc_size, str;
80ee04b9	277
644cb69f	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	}
644cb69f	288
92e6f3a4	289	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
80ee04b9	290
644cb69f	291	retarray->offset = 0;
fa3c4d47	292	GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
80ee04b9 TK	293
	294	if (alloc_size == 0)
	295	{
	296	/* Make sure we have a zero-sized array. */
dfb55fdc	297	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9 TK	298	return;
	299	}
	300	else
92e6f3a4	301	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
80ee04b9	302
644cb69f FXC	303	}
	304	else
	305	{
644cb69f	306	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8 TK	307	runtime_error ("rank of return array incorrect in SUM intrinsic");
fd6590f8 TK	308
9731c4a3	309	if (unlikely (compile_options.bounds_check))
fd6590f8	310	{
16bff921 TK	311	bounds_ifunction_return ((array_t *) retarray, extent,
	312	"return value", "SUM");
	313	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	314	"MASK argument", "SUM");
fd6590f8	315	}
644cb69f FXC	316	}
	317
	318	for (n = 0; n < rank; n++)
	319	{
	320	count[n] = 0;
dfb55fdc	321	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
644cb69f	322	if (extent[n] <= 0)
80927a56	323	return;
644cb69f FXC	324	}
644cb69f FXC	325
21d1335b TB	326	dest = retarray->base_addr;
21d1335b TB	327	base = array->base_addr;
644cb69f FXC	328
	329	while (base)
	330	{
64acfd99	331	const GFC_INTEGER_16 * restrict src;
28dc6b33	332	const GFC_LOGICAL_1 * restrict msrc;
644cb69f FXC	333	GFC_INTEGER_16 result;
	334	src = base;
	335	msrc = mbase;
	336	{
	337
	338	result = 0;
036e1775	339	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
644cb69f	340	{
644cb69f FXC	341
	342	if (*msrc)
	343	result += *src;
644cb69f	344	}
036e1775	345	*dest = result;
644cb69f FXC	346	}
	347	/* Advance to the next element. */
	348	count[0]++;
	349	base += sstride[0];
	350	mbase += mstride[0];
	351	dest += dstride[0];
	352	n = 0;
	353	while (count[n] == extent[n])
80927a56 JJ	354	{
	355	/* When we get to the end of a dimension, reset it and increment
	356	the next dimension. */
	357	count[n] = 0;
	358	/* We could precalculate these products, but this is a less
	359	frequently used path so probably not worth it. */
	360	base -= sstride[n] * extent[n];
	361	mbase -= mstride[n] * extent[n];
	362	dest -= dstride[n] * extent[n];
	363	n++;
80dd631f	364	if (n >= rank)
80927a56	365	{
80dd631f	366	/* Break out of the loop. */
80927a56 JJ	367	base = NULL;
	368	break;
	369	}
	370	else
	371	{
	372	count[n]++;
	373	base += sstride[n];
	374	mbase += mstride[n];
	375	dest += dstride[n];
	376	}
	377	}
644cb69f FXC	378	}
	379	}
	380
97a62038 TK	381
	382	extern void ssum_i16 (gfc_array_i16 * const restrict,
	383	gfc_array_i16 * const restrict, const index_type * const restrict,
	384	GFC_LOGICAL_4 *);
	385	export_proto(ssum_i16);
	386
	387	void
	388	ssum_i16 (gfc_array_i16 * const restrict retarray,
	389	gfc_array_i16 * const restrict array,
	390	const index_type * const restrict pdim,
	391	GFC_LOGICAL_4 * mask)
	392	{
802367d7 TK	393	index_type count[GFC_MAX_DIMENSIONS];
802367d7 TK	394	index_type extent[GFC_MAX_DIMENSIONS];
802367d7 TK	395	index_type dstride[GFC_MAX_DIMENSIONS];
802367d7 TK	396	GFC_INTEGER_16 * restrict dest;
97a62038 TK	397	index_type rank;
97a62038 TK	398	index_type n;
802367d7 TK	399	index_type dim;
802367d7 TK	400
97a62038 TK	401
	402	if (*mask)
	403	{
64b1806b TK	404	#ifdef HAVE_BACK_ARG
	405	sum_i16 (retarray, array, pdim, back);
	406	#else
97a62038	407	sum_i16 (retarray, array, pdim);
64b1806b	408	#endif
97a62038 TK	409	return;
97a62038 TK	410	}
802367d7 TK	411	/* Make dim zero based to avoid confusion. */
	412	dim = (*pdim) - 1;
	413	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	414
cfdf6ff6 TK	415	if (unlikely (dim < 0 \|\| dim > rank))
	416	{
	417	runtime_error ("Dim argument incorrect in SUM intrinsic: "
	418	"is %ld, should be between 1 and %ld",
	419	(long int) dim + 1, (long int) rank + 1);
	420	}
	421
802367d7 TK	422	for (n = 0; n < dim; n++)
802367d7 TK	423	{
dfb55fdc	424	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
802367d7 TK	425
	426	if (extent[n] <= 0)
	427	extent[n] = 0;
	428	}
	429
	430	for (n = dim; n < rank; n++)
	431	{
802367d7	432	extent[n] =
80927a56	433	GFC_DESCRIPTOR_EXTENT(array,n + 1);
802367d7 TK	434
802367d7 TK	435	if (extent[n] <= 0)
80927a56	436	extent[n] = 0;
802367d7	437	}
97a62038	438
21d1335b	439	if (retarray->base_addr == NULL)
97a62038	440	{
dfb55fdc	441	size_t alloc_size, str;
802367d7 TK	442
802367d7 TK	443	for (n = 0; n < rank; n++)
80927a56 JJ	444	{
	445	if (n == 0)
	446	str = 1;
	447	else
	448	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	449
	450	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	451
80927a56	452	}
802367d7	453
97a62038	454	retarray->offset = 0;
fa3c4d47	455	GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
802367d7	456
92e6f3a4	457	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
802367d7 TK	458
	459	if (alloc_size == 0)
	460	{
	461	/* Make sure we have a zero-sized array. */
dfb55fdc	462	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
802367d7 TK	463	return;
	464	}
	465	else
92e6f3a4	466	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
97a62038 TK	467	}
	468	else
	469	{
802367d7 TK	470	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	471	runtime_error ("rank of return array incorrect in"
	472	" SUM intrinsic: is %ld, should be %ld",
	473	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	474	(long int) rank);
	475
9731c4a3	476	if (unlikely (compile_options.bounds_check))
fd6590f8	477	{
802367d7 TK	478	for (n=0; n < rank; n++)
	479	{
	480	index_type ret_extent;
97a62038	481
dfb55fdc	482	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
802367d7 TK	483	if (extent[n] != ret_extent)
	484	runtime_error ("Incorrect extent in return value of"
	485	" SUM intrinsic in dimension %ld:"
	486	" is %ld, should be %ld", (long int) n + 1,
	487	(long int) ret_extent, (long int) extent[n]);
	488	}
fd6590f8 TK	489	}
fd6590f8 TK	490	}
97a62038	491
802367d7 TK	492	for (n = 0; n < rank; n++)
	493	{
	494	count[n] = 0;
dfb55fdc	495	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
802367d7 TK	496	}
802367d7 TK	497
21d1335b	498	dest = retarray->base_addr;
802367d7 TK	499
	500	while(1)
	501	{
	502	*dest = 0;
	503	count[0]++;
	504	dest += dstride[0];
	505	n = 0;
	506	while (count[n] == extent[n])
80927a56	507	{
802367d7	508	/* When we get to the end of a dimension, reset it and increment
80927a56 JJ	509	the next dimension. */
	510	count[n] = 0;
	511	/* We could precalculate these products, but this is a less
	512	frequently used path so probably not worth it. */
	513	dest -= dstride[n] * extent[n];
	514	n++;
80dd631f	515	if (n >= rank)
802367d7	516	return;
80927a56 JJ	517	else
	518	{
	519	count[n]++;
	520	dest += dstride[n];
	521	}
802367d7 TK	522	}
802367d7 TK	523	}
97a62038 TK	524	}
97a62038 TK	525
644cb69f	526	#endif