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

/* Implementation of the IALL intrinsic
   Copyright (C) 2010-2017 Free Software Foundation, Inc.
   Contributed by Tobias Burnus <burnus@net-b.de>

This file is part of the GNU Fortran 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 iall_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict);
export_proto(iall_i16);

void
iall_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.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

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

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

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

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

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

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

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

	}

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

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

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

  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 = (GFC_INTEGER_16) -1;
	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 miall_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(miall_i16);

void
miall_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;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

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

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

  mbase = mask->base_addr;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

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

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

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

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

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

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

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

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

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

	}

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

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

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

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

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

  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 look.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


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

void
siall_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)
    {
      iall_i16 (retarray, array, pdim);
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

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

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

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

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

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

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

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

	}

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

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

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