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

/* Implementation of the PRODUCT intrinsic
   Copyright (C) 2002-2019 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_REAL_16) && defined (HAVE_GFC_REAL_16)


extern void product_r16 (gfc_array_r16 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict);
export_proto(product_r16);

void
product_r16 (gfc_array_r16 * const restrict retarray, 
	gfc_array_r16 * 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_REAL_16 * restrict base;
  GFC_REAL_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_REAL_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_REAL_16 * restrict src;
      GFC_REAL_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_r16 (gfc_array_r16 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mproduct_r16);

void
mproduct_r16 (gfc_array_r16 * const restrict retarray, 
	gfc_array_r16 * 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_REAL_16 * restrict dest;
  const GFC_REAL_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_r16 (retarray, array, pdim, back);
#else
      product_r16 (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_REAL_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_REAL_16 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_REAL_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_r16 (gfc_array_r16 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sproduct_r16);

void
sproduct_r16 (gfc_array_r16 * const restrict retarray, 
	gfc_array_r16 * 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_REAL_16 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      product_r16 (retarray, array, pdim, back);
#else
      product_r16 (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_REAL_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
920e54ef	1	/* Implementation of the PRODUCT intrinsic
fbd26352	2	Copyright (C) 2002-2019 Free Software Foundation, Inc.
920e54ef	3	Contributed by Paul Brook <paul@nowt.org>
920e54ef	4
b4ba8232	5	This file is part of the GNU Fortran runtime library (libgfortran).
920e54ef	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
6bc9506f	10	version 3 of the License, or (at your option) any later version.
920e54ef	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
6bc9506f	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/>. */
920e54ef	25
41f2d5e8	26	#include "libgfortran.h"
920e54ef	27
	28
	29	#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_REAL_16)
	30
	31
b4cafd67	32	extern void product_r16 (gfc_array_r16 * const restrict,
b4cafd67	33	gfc_array_r16 * const restrict, const index_type * const restrict);
920e54ef	34	export_proto(product_r16);
	35
	36	void
b4cafd67	37	product_r16 (gfc_array_r16 * const restrict retarray,
	38	gfc_array_r16 * const restrict array,
	39	const index_type * const restrict pdim)
920e54ef	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];
b4cafd67	45	const GFC_REAL_16 * restrict base;
b4cafd67	46	GFC_REAL_16 * restrict dest;
920e54ef	47	index_type rank;
	48	index_type n;
	49	index_type len;
	50	index_type delta;
	51	index_type dim;
393a1b6c	52	int continue_loop;
920e54ef	53
920e54ef	54	/* Make dim zero based to avoid confusion. */
920e54ef	55	rank = GFC_DESCRIPTOR_RANK (array) - 1;
3a33b9df	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	}
920e54ef	64
827aef63	65	len = GFC_DESCRIPTOR_EXTENT(array,dim);
393a1b6c	66	if (len < 0)
393a1b6c	67	len = 0;
827aef63	68	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
920e54ef	69
	70	for (n = 0; n < dim; n++)
	71	{
827aef63	72	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
827aef63	73	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
a14c06e9	74
	75	if (extent[n] < 0)
	76	extent[n] = 0;
920e54ef	77	}
	78	for (n = dim; n < rank; n++)
	79	{
827aef63	80	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
827aef63	81	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
a14c06e9	82
	83	if (extent[n] < 0)
	84	extent[n] = 0;
920e54ef	85	}
920e54ef	86
553877d9	87	if (retarray->base_addr == NULL)
920e54ef	88	{
827aef63	89	size_t alloc_size, str;
a14c06e9	90
920e54ef	91	for (n = 0; n < rank; n++)
7ebee933	92	{
7ebee933	93	if (n == 0)
827aef63	94	str = 1;
7ebee933	95	else
7ebee933	96	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
827aef63	97
	98	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	99
7ebee933	100	}
920e54ef	101
920e54ef	102	retarray->offset = 0;
0bb0be20	103	retarray->dtype.rank = rank;
a14c06e9	104
af1e9051	105	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
a14c06e9	106
af1e9051	107	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_16));
a14c06e9	108	if (alloc_size == 0)
	109	{
	110	/* Make sure we have a zero-sized array. */
827aef63	111	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
a14c06e9	112	return;
827aef63	113
a14c06e9	114	}
920e54ef	115	}
	116	else
	117	{
920e54ef	118	if (rank != GFC_DESCRIPTOR_RANK (retarray))
8dec97a0	119	runtime_error ("rank of return array incorrect in"
ae66f8f3	120	" PRODUCT intrinsic: is %ld, should be %ld",
	121	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	122	(long int) rank);
8dec97a0	123
c7fb575f	124	if (unlikely (compile_options.bounds_check))
5d04d450	125	bounds_ifunction_return ((array_t *) retarray, extent,
5d04d450	126	"return value", "PRODUCT");
920e54ef	127	}
	128
	129	for (n = 0; n < rank; n++)
	130	{
	131	count[n] = 0;
827aef63	132	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
920e54ef	133	if (extent[n] <= 0)
7cbf86e5	134	return;
920e54ef	135	}
920e54ef	136
553877d9	137	base = array->base_addr;
553877d9	138	dest = retarray->base_addr;
920e54ef	139
393a1b6c	140	continue_loop = 1;
393a1b6c	141	while (continue_loop)
920e54ef	142	{
b4cafd67	143	const GFC_REAL_16 * restrict src;
920e54ef	144	GFC_REAL_16 result;
	145	src = base;
	146	{
	147
	148	result = 1;
7ebee933	149	if (len <= 0)
920e54ef	150	*dest = 1;
	151	else
	152	{
ca96069a	153	#if ! defined HAVE_BACK_ARG
920e54ef	154	for (n = 0; n < len; n++, src += delta)
920e54ef	155	{
ca96069a	156	#endif
920e54ef	157
920e54ef	158	result = src;
7ebee933	159	}
b4ba8232	160
920e54ef	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])
7ebee933	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++;
bacde0a1	179	if (n >= rank)
7ebee933	180	{
bacde0a1	181	/* Break out of the loop. */
393a1b6c	182	continue_loop = 0;
393a1b6c	183	break;
7ebee933	184	}
	185	else
	186	{
	187	count[n]++;
	188	base += sstride[n];
	189	dest += dstride[n];
	190	}
	191	}
920e54ef	192	}
	193	}
	194
	195
b4cafd67	196	extern void mproduct_r16 (gfc_array_r16 * const restrict,
b4cafd67	197	gfc_array_r16 * const restrict, const index_type * const restrict,
7ed8f627	198	gfc_array_l1 * const restrict);
920e54ef	199	export_proto(mproduct_r16);
	200
	201	void
b4cafd67	202	mproduct_r16 (gfc_array_r16 * const restrict retarray,
	203	gfc_array_r16 * const restrict array,
	204	const index_type * const restrict pdim,
7ed8f627	205	gfc_array_l1 * const restrict mask)
920e54ef	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];
b4cafd67	212	GFC_REAL_16 * restrict dest;
b4cafd67	213	const GFC_REAL_16 * restrict base;
7ed8f627	214	const GFC_LOGICAL_1 * restrict mbase;
3a33b9df	215	index_type rank;
3a33b9df	216	index_type dim;
920e54ef	217	index_type n;
	218	index_type len;
	219	index_type delta;
	220	index_type mdelta;
7ed8f627	221	int mask_kind;
920e54ef	222
538bdcdc	223	if (mask == NULL)
	224	{
	225	#ifdef HAVE_BACK_ARG
	226	product_r16 (retarray, array, pdim, back);
	227	#else
	228	product_r16 (retarray, array, pdim);
	229	#endif
	230	return;
	231	}
	232
920e54ef	233	dim = (*pdim) - 1;
	234	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	235
3a33b9df	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
827aef63	244	len = GFC_DESCRIPTOR_EXTENT(array,dim);
920e54ef	245	if (len <= 0)
920e54ef	246	return;
7ed8f627	247
553877d9	248	mbase = mask->base_addr;
7ed8f627	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
827aef63	261	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
827aef63	262	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
920e54ef	263
	264	for (n = 0; n < dim; n++)
	265	{
827aef63	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);
a14c06e9	269
	270	if (extent[n] < 0)
	271	extent[n] = 0;
	272
920e54ef	273	}
	274	for (n = dim; n < rank; n++)
	275	{
827aef63	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);
a14c06e9	279
	280	if (extent[n] < 0)
	281	extent[n] = 0;
920e54ef	282	}
920e54ef	283
553877d9	284	if (retarray->base_addr == NULL)
920e54ef	285	{
827aef63	286	size_t alloc_size, str;
a14c06e9	287
920e54ef	288	for (n = 0; n < rank; n++)
7ebee933	289	{
	290	if (n == 0)
	291	str = 1;
	292	else
	293	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
827aef63	294
	295	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	296
7ebee933	297	}
920e54ef	298
af1e9051	299	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
a14c06e9	300
920e54ef	301	retarray->offset = 0;
0bb0be20	302	retarray->dtype.rank = rank;
a14c06e9	303
	304	if (alloc_size == 0)
	305	{
	306	/* Make sure we have a zero-sized array. */
827aef63	307	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
a14c06e9	308	return;
	309	}
	310	else
af1e9051	311	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_16));
a14c06e9	312
920e54ef	313	}
	314	else
	315	{
920e54ef	316	if (rank != GFC_DESCRIPTOR_RANK (retarray))
8dec97a0	317	runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
8dec97a0	318
c7fb575f	319	if (unlikely (compile_options.bounds_check))
8dec97a0	320	{
5d04d450	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");
8dec97a0	325	}
920e54ef	326	}
	327
	328	for (n = 0; n < rank; n++)
	329	{
	330	count[n] = 0;
827aef63	331	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
920e54ef	332	if (extent[n] <= 0)
7ebee933	333	return;
920e54ef	334	}
920e54ef	335
553877d9	336	dest = retarray->base_addr;
553877d9	337	base = array->base_addr;
920e54ef	338
	339	while (base)
	340	{
b4cafd67	341	const GFC_REAL_16 * restrict src;
7ed8f627	342	const GFC_LOGICAL_1 * restrict msrc;
920e54ef	343	GFC_REAL_16 result;
	344	src = base;
	345	msrc = mbase;
	346	{
	347
	348	result = 1;
08e1eb56	349	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
920e54ef	350	{
920e54ef	351
	352	if (*msrc)
	353	result = src;
920e54ef	354	}
08e1eb56	355	*dest = result;
920e54ef	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])
7ebee933	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++;
bacde0a1	374	if (n >= rank)
7ebee933	375	{
bacde0a1	376	/* Break out of the loop. */
7ebee933	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	}
920e54ef	388	}
	389	}
	390
4292b27d	391
	392	extern void sproduct_r16 (gfc_array_r16 * const restrict,
	393	gfc_array_r16 * const restrict, const index_type * const restrict,
	394	GFC_LOGICAL_4 *);
	395	export_proto(sproduct_r16);
	396
	397	void
	398	sproduct_r16 (gfc_array_r16 * const restrict retarray,
	399	gfc_array_r16 * const restrict array,
	400	const index_type * const restrict pdim,
	401	GFC_LOGICAL_4 * mask)
	402	{
f955bfc4	403	index_type count[GFC_MAX_DIMENSIONS];
f955bfc4	404	index_type extent[GFC_MAX_DIMENSIONS];
f955bfc4	405	index_type dstride[GFC_MAX_DIMENSIONS];
f955bfc4	406	GFC_REAL_16 * restrict dest;
4292b27d	407	index_type rank;
4292b27d	408	index_type n;
f955bfc4	409	index_type dim;
f955bfc4	410
4292b27d	411
538bdcdc	412	if (mask == NULL \|\| *mask)
4292b27d	413	{
cb458068	414	#ifdef HAVE_BACK_ARG
	415	product_r16 (retarray, array, pdim, back);
	416	#else
4292b27d	417	product_r16 (retarray, array, pdim);
cb458068	418	#endif
4292b27d	419	return;
4292b27d	420	}
f955bfc4	421	/* Make dim zero based to avoid confusion. */
	422	dim = (*pdim) - 1;
	423	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	424
3a33b9df	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
f955bfc4	432	for (n = 0; n < dim; n++)
f955bfc4	433	{
827aef63	434	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
f955bfc4	435
	436	if (extent[n] <= 0)
	437	extent[n] = 0;
	438	}
	439
	440	for (n = dim; n < rank; n++)
	441	{
f955bfc4	442	extent[n] =
7ebee933	443	GFC_DESCRIPTOR_EXTENT(array,n + 1);
f955bfc4	444
f955bfc4	445	if (extent[n] <= 0)
7ebee933	446	extent[n] = 0;
f955bfc4	447	}
4292b27d	448
553877d9	449	if (retarray->base_addr == NULL)
4292b27d	450	{
827aef63	451	size_t alloc_size, str;
f955bfc4	452
f955bfc4	453	for (n = 0; n < rank; n++)
7ebee933	454	{
	455	if (n == 0)
	456	str = 1;
	457	else
	458	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
827aef63	459
	460	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	461
7ebee933	462	}
f955bfc4	463
4292b27d	464	retarray->offset = 0;
0bb0be20	465	retarray->dtype.rank = rank;
f955bfc4	466
af1e9051	467	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
f955bfc4	468
	469	if (alloc_size == 0)
	470	{
	471	/* Make sure we have a zero-sized array. */
827aef63	472	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
f955bfc4	473	return;
	474	}
	475	else
af1e9051	476	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_REAL_16));
4292b27d	477	}
	478	else
	479	{
f955bfc4	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
c7fb575f	486	if (unlikely (compile_options.bounds_check))
8dec97a0	487	{
f955bfc4	488	for (n=0; n < rank; n++)
	489	{
	490	index_type ret_extent;
4292b27d	491
827aef63	492	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
f955bfc4	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	}
8dec97a0	499	}
8dec97a0	500	}
4292b27d	501
f955bfc4	502	for (n = 0; n < rank; n++)
	503	{
	504	count[n] = 0;
827aef63	505	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
f955bfc4	506	}
f955bfc4	507
553877d9	508	dest = retarray->base_addr;
f955bfc4	509
	510	while(1)
	511	{
	512	*dest = 1;
	513	count[0]++;
	514	dest += dstride[0];
	515	n = 0;
	516	while (count[n] == extent[n])
7ebee933	517	{
f955bfc4	518	/* When we get to the end of a dimension, reset it and increment
7ebee933	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++;
bacde0a1	525	if (n >= rank)
f955bfc4	526	return;
7ebee933	527	else
	528	{
	529	count[n]++;
	530	dest += dstride[n];
	531	}
f955bfc4	532	}
f955bfc4	533	}
4292b27d	534	}
4292b27d	535
920e54ef	536	#endif