[thirdparty/gcc.git] / libgfortran / generated / sum_i4.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_4) && defined (HAVE_GFC_INTEGER_4)


extern void sum_i4 (gfc_array_i4 * const restrict, 
	gfc_array_i4 * const restrict, const index_type * const restrict);
export_proto(sum_i4);

void
sum_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * 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_4 * restrict base;
  GFC_INTEGER_4 * 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 = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  if (len < 0)
    len = 0;
  delta = array->dim[dim].stride;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

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

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

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

      alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
    		   * extent[rank-1];

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -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 = retarray->dim[n].ubound + 1
		- retarray->dim[n].lbound;
	      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] = retarray->dim[n].stride;
      if (extent[n] <= 0)
        len = 0;
    }

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

  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_INTEGER_4 * restrict src;
      GFC_INTEGER_4 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_i4 (gfc_array_i4 * const restrict, 
	gfc_array_i4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(msum_i4);

void
msum_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * 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_4 * restrict dest;
  const GFC_INTEGER_4 * 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 = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  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 = array->dim[dim].stride;
  mdelta = mask->dim[dim].stride * mask_kind;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride * mask_kind;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

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

    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      mstride[n] = mask->dim[n + 1].stride * mask_kind;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

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

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

      alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
    		   * 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.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -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))
	{
	  for (n=0; n < rank; n++)
	    {
	      index_type ret_extent;

	      ret_extent = retarray->dim[n].ubound + 1
		- retarray->dim[n].lbound;
	      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++)
            {
              index_type mask_extent, array_extent;

	      array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
	      mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
	      if (array_extent != mask_extent)
		runtime_error ("Incorrect extent in MASK argument of"
			       " SUM intrinsic in dimension %ld:"
			       " is %ld, should be %ld", (long int) n + 1,
			       (long int) mask_extent, (long int) array_extent);
	    }
	}
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = retarray->dim[n].stride;
      if (extent[n] <= 0)
        return;
    }

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

  while (base)
    {
      const GFC_INTEGER_4 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_4 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_i4 (gfc_array_i4 * const restrict, 
	gfc_array_i4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(ssum_i4);

void
ssum_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * 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 sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      sum_i4 (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++)
    {
      sstride[n] = array->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

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

  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

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

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

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

      alloc_size = sizeof (GFC_INTEGER_4) * retarray->dim[rank-1].stride
    		   * extent[rank-1];

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -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 = retarray->dim[n].ubound + 1
		- retarray->dim[n].lbound;
	      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] = retarray->dim[n].stride;
    }

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