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

/* Implementation of the PRODUCT intrinsic
   Copyright (C) 2002-2023 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

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 product_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict);
export_proto(product_i16);

void
product_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 PRODUCT 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_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"
		       " PRODUCT 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", "PRODUCT");
    }

  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 = 1;
	if (len <= 0)
	  *dest = 1;
	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 mproduct_i16 (gfc_array_i16 * const restrict, 
	gfc_array_i16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mproduct_i16);

void
mproduct_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;

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

      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 PRODUCT intrinsic");

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

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

void
sproduct_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 == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      product_i16 (retarray, array, pdim, back);
#else
      product_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 PRODUCT 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];

      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"
		       " PRODUCT 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"
			       " PRODUCT 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 = 1;
      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 PRODUCT intrinsic
83ffe9cd	2	Copyright (C) 2002-2023 Free Software Foundation, Inc.
644cb69f FXC	3	Contributed by Paul Brook <paul@nowt.org>
644cb69f FXC	4
0cd0559e	5	This file is part of the GNU Fortran runtime library (libgfortran).
644cb69f FXC	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 product_i16 (gfc_array_i16 * const restrict,
64acfd99 JB	33	gfc_array_i16 * const restrict, const index_type * const restrict);
644cb69f FXC	34	export_proto(product_i16);
	35
	36	void
64acfd99 JB	37	product_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 PRODUCT 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;
ca708a2b	103	retarray->dtype.rank = 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	" PRODUCT 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", "PRODUCT");
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 = 1;
80927a56	149	if (len <= 0)
644cb69f FXC	150	*dest = 1;
	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 mproduct_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(mproduct_i16);
	200
	201	void
64acfd99 JB	202	mproduct_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	222
2ea47ee9 TK	223	if (mask == NULL)
	224	{
	225	#ifdef HAVE_BACK_ARG
	226	product_i16 (retarray, array, pdim, back);
	227	#else
	228	product_i16 (retarray, array, pdim);
	229	#endif
	230	return;
	231	}
	232
644cb69f FXC	233	dim = (*pdim) - 1;
	234	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	235
cfdf6ff6 TK	236
	237	if (unlikely (dim < 0 \|\| dim > rank))
	238	{
	239	runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
	240	"is %ld, should be between 1 and %ld",
	241	(long int) dim + 1, (long int) rank + 1);
	242	}
	243
dfb55fdc	244	len = GFC_DESCRIPTOR_EXTENT(array,dim);
644cb69f FXC	245	if (len <= 0)
644cb69f FXC	246	return;
28dc6b33	247
21d1335b	248	mbase = mask->base_addr;
28dc6b33 TK	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
dfb55fdc TK	261	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
dfb55fdc TK	262	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
644cb69f FXC	263
	264	for (n = 0; n < dim; n++)
	265	{
dfb55fdc TK	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);
80ee04b9 TK	269
	270	if (extent[n] < 0)
	271	extent[n] = 0;
	272
644cb69f FXC	273	}
	274	for (n = dim; n < rank; n++)
	275	{
dfb55fdc TK	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);
80ee04b9 TK	279
	280	if (extent[n] < 0)
	281	extent[n] = 0;
644cb69f FXC	282	}
644cb69f FXC	283
21d1335b	284	if (retarray->base_addr == NULL)
644cb69f	285	{
dfb55fdc	286	size_t alloc_size, str;
80ee04b9	287
644cb69f	288	for (n = 0; n < rank; n++)
80927a56 JJ	289	{
	290	if (n == 0)
	291	str = 1;
	292	else
	293	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	294
	295	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	296
80927a56	297	}
644cb69f	298
92e6f3a4	299	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
80ee04b9	300
644cb69f	301	retarray->offset = 0;
ca708a2b	302	retarray->dtype.rank = rank;
80ee04b9 TK	303
	304	if (alloc_size == 0)
	305	{
	306	/* Make sure we have a zero-sized array. */
dfb55fdc	307	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9 TK	308	return;
	309	}
	310	else
92e6f3a4	311	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
80ee04b9	312
644cb69f FXC	313	}
	314	else
	315	{
644cb69f	316	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8 TK	317	runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
fd6590f8 TK	318
9731c4a3	319	if (unlikely (compile_options.bounds_check))
fd6590f8	320	{
16bff921 TK	321	bounds_ifunction_return ((array_t *) retarray, extent,
	322	"return value", "PRODUCT");
	323	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	324	"MASK argument", "PRODUCT");
fd6590f8	325	}
644cb69f FXC	326	}
	327
	328	for (n = 0; n < rank; n++)
	329	{
	330	count[n] = 0;
dfb55fdc	331	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
644cb69f	332	if (extent[n] <= 0)
80927a56	333	return;
644cb69f FXC	334	}
644cb69f FXC	335
21d1335b TB	336	dest = retarray->base_addr;
21d1335b TB	337	base = array->base_addr;
644cb69f FXC	338
	339	while (base)
	340	{
64acfd99	341	const GFC_INTEGER_16 * restrict src;
28dc6b33	342	const GFC_LOGICAL_1 * restrict msrc;
644cb69f FXC	343	GFC_INTEGER_16 result;
	344	src = base;
	345	msrc = mbase;
	346	{
	347
	348	result = 1;
036e1775	349	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
644cb69f	350	{
644cb69f FXC	351
	352	if (*msrc)
	353	result = src;
644cb69f	354	}
036e1775	355	*dest = result;
644cb69f FXC	356	}
	357	/* Advance to the next element. */
	358	count[0]++;
	359	base += sstride[0];
	360	mbase += mstride[0];
	361	dest += dstride[0];
	362	n = 0;
	363	while (count[n] == extent[n])
80927a56 JJ	364	{
	365	/* When we get to the end of a dimension, reset it and increment
	366	the next dimension. */
	367	count[n] = 0;
	368	/* We could precalculate these products, but this is a less
	369	frequently used path so probably not worth it. */
	370	base -= sstride[n] * extent[n];
	371	mbase -= mstride[n] * extent[n];
	372	dest -= dstride[n] * extent[n];
	373	n++;
80dd631f	374	if (n >= rank)
80927a56	375	{
80dd631f	376	/* Break out of the loop. */
80927a56 JJ	377	base = NULL;
	378	break;
	379	}
	380	else
	381	{
	382	count[n]++;
	383	base += sstride[n];
	384	mbase += mstride[n];
	385	dest += dstride[n];
	386	}
	387	}
644cb69f FXC	388	}
	389	}
	390
97a62038 TK	391
	392	extern void sproduct_i16 (gfc_array_i16 * const restrict,
	393	gfc_array_i16 * const restrict, const index_type * const restrict,
	394	GFC_LOGICAL_4 *);
	395	export_proto(sproduct_i16);
	396
	397	void
	398	sproduct_i16 (gfc_array_i16 * const restrict retarray,
	399	gfc_array_i16 * const restrict array,
	400	const index_type * const restrict pdim,
	401	GFC_LOGICAL_4 * mask)
	402	{
802367d7 TK	403	index_type count[GFC_MAX_DIMENSIONS];
802367d7 TK	404	index_type extent[GFC_MAX_DIMENSIONS];
802367d7 TK	405	index_type dstride[GFC_MAX_DIMENSIONS];
802367d7 TK	406	GFC_INTEGER_16 * restrict dest;
97a62038 TK	407	index_type rank;
97a62038 TK	408	index_type n;
802367d7 TK	409	index_type dim;
802367d7 TK	410
97a62038	411
2ea47ee9	412	if (mask == NULL \|\| *mask)
97a62038	413	{
64b1806b TK	414	#ifdef HAVE_BACK_ARG
	415	product_i16 (retarray, array, pdim, back);
	416	#else
97a62038	417	product_i16 (retarray, array, pdim);
64b1806b	418	#endif
97a62038 TK	419	return;
97a62038 TK	420	}
802367d7 TK	421	/* Make dim zero based to avoid confusion. */
	422	dim = (*pdim) - 1;
	423	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	424
cfdf6ff6 TK	425	if (unlikely (dim < 0 \|\| dim > rank))
	426	{
	427	runtime_error ("Dim argument incorrect in PRODUCT intrinsic: "
	428	"is %ld, should be between 1 and %ld",
	429	(long int) dim + 1, (long int) rank + 1);
	430	}
	431
802367d7 TK	432	for (n = 0; n < dim; n++)
802367d7 TK	433	{
dfb55fdc	434	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
802367d7 TK	435
	436	if (extent[n] <= 0)
	437	extent[n] = 0;
	438	}
	439
	440	for (n = dim; n < rank; n++)
	441	{
802367d7	442	extent[n] =
80927a56	443	GFC_DESCRIPTOR_EXTENT(array,n + 1);
802367d7 TK	444
802367d7 TK	445	if (extent[n] <= 0)
80927a56	446	extent[n] = 0;
802367d7	447	}
97a62038	448
21d1335b	449	if (retarray->base_addr == NULL)
97a62038	450	{
dfb55fdc	451	size_t alloc_size, str;
802367d7 TK	452
802367d7 TK	453	for (n = 0; n < rank; n++)
80927a56 JJ	454	{
	455	if (n == 0)
	456	str = 1;
	457	else
	458	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	459
	460	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	461
80927a56	462	}
802367d7	463
97a62038	464	retarray->offset = 0;
ca708a2b	465	retarray->dtype.rank = rank;
802367d7	466
92e6f3a4	467	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
802367d7 TK	468
	469	if (alloc_size == 0)
	470	{
	471	/* Make sure we have a zero-sized array. */
dfb55fdc	472	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
802367d7 TK	473	return;
	474	}
	475	else
92e6f3a4	476	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
97a62038 TK	477	}
	478	else
	479	{
802367d7 TK	480	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	481	runtime_error ("rank of return array incorrect in"
	482	" PRODUCT intrinsic: is %ld, should be %ld",
	483	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	484	(long int) rank);
	485
9731c4a3	486	if (unlikely (compile_options.bounds_check))
fd6590f8	487	{
802367d7 TK	488	for (n=0; n < rank; n++)
	489	{
	490	index_type ret_extent;
97a62038	491
dfb55fdc	492	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
802367d7 TK	493	if (extent[n] != ret_extent)
	494	runtime_error ("Incorrect extent in return value of"
	495	" PRODUCT intrinsic in dimension %ld:"
	496	" is %ld, should be %ld", (long int) n + 1,
	497	(long int) ret_extent, (long int) extent[n]);
	498	}
fd6590f8 TK	499	}
fd6590f8 TK	500	}
97a62038	501
802367d7 TK	502	for (n = 0; n < rank; n++)
	503	{
	504	count[n] = 0;
dfb55fdc	505	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
802367d7 TK	506	}
802367d7 TK	507
21d1335b	508	dest = retarray->base_addr;
802367d7 TK	509
	510	while(1)
	511	{
	512	*dest = 1;
	513	count[0]++;
	514	dest += dstride[0];
	515	n = 0;
	516	while (count[n] == extent[n])
80927a56	517	{
802367d7	518	/* When we get to the end of a dimension, reset it and increment
80927a56 JJ	519	the next dimension. */
	520	count[n] = 0;
	521	/* We could precalculate these products, but this is a less
	522	frequently used path so probably not worth it. */
	523	dest -= dstride[n] * extent[n];
	524	n++;
80dd631f	525	if (n >= rank)
802367d7	526	return;
80927a56 JJ	527	else
	528	{
	529	count[n]++;
	530	dest += dstride[n];
	531	}
802367d7 TK	532	}
802367d7 TK	533	}
97a62038 TK	534	}
97a62038 TK	535
644cb69f	536	#endif