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

/* Implementation of the PRODUCT intrinsic
   Copyright 2002 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 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#include "config.h"
#include <stdlib.h>
#include <assert.h>
#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;

  /* 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;
  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_16) * 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");
    }

  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;

  while (base)
    {
      const GFC_INTEGER_16 * restrict src;
      GFC_INTEGER_16 result;
      src = base;
      {

  result = 1;
        if (len <= 0)
	  *dest = 1;
	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.  */
              base = NULL;
              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;
  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_16) * 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");
    }

  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_16 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_16 result;
      src = base;
      msrc = mbase;
      {

  result = 1;
        if (len <= 0)
	  *dest = 1;
	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 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 rank;
  index_type n;
  index_type dstride;
  GFC_INTEGER_16 *dest;

  if (*mask)
    {
      product_i16 (retarray, array, pdim);
      return;
    }
    rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->data == NULL)
    {
      retarray->dim[0].lbound = 0;
      retarray->dim[0].ubound = rank-1;
      retarray->dim[0].stride = 1;
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
    }
  else
    {
      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
	runtime_error ("rank of return array does not equal 1");

      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
        runtime_error ("dimension of return array incorrect");
    }

    dstride = retarray->dim[0].stride;
    dest = retarray->data;

    for (n = 0; n < rank; n++)
      dest[n * dstride] = 1 ;
}

#endif
Commit	Line	Data
644cb69f FXC	1	/* Implementation of the PRODUCT intrinsic
	2	Copyright 2002 Free Software Foundation, Inc.
	3	Contributed by Paul Brook <paul@nowt.org>
	4
	5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	6
	7	Libgfortran is free software; you can redistribute it and/or
	8	modify it under the terms of the GNU General Public
	9	License as published by the Free Software Foundation; either
	10	version 2 of the License, or (at your option) any later version.
	11
	12	In addition to the permissions in the GNU General Public License, the
	13	Free Software Foundation gives you unlimited permission to link the
	14	compiled version of this file into combinations with other programs,
	15	and to distribute those combinations without any restriction coming
	16	from the use of this file. (The General Public License restrictions
	17	do apply in other respects; for example, they cover modification of
	18	the file, and distribution when not linked into a combine
	19	executable.)
	20
	21	Libgfortran is distributed in the hope that it will be useful,
	22	but WITHOUT ANY WARRANTY; without even the implied warranty of
	23	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	24	GNU General Public License for more details.
	25
	26	You should have received a copy of the GNU General Public
	27	License along with libgfortran; see the file COPYING. If not,
	28	write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
	29	Boston, MA 02110-1301, USA. */
	30
	31	#include "config.h"
	32	#include <stdlib.h>
	33	#include <assert.h>
	34	#include "libgfortran.h"
	35
	36
	37	#if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16)
	38
	39
64acfd99 JB	40	extern void product_i16 (gfc_array_i16 * const restrict,
64acfd99 JB	41	gfc_array_i16 * const restrict, const index_type * const restrict);
644cb69f FXC	42	export_proto(product_i16);
	43
	44	void
64acfd99 JB	45	product_i16 (gfc_array_i16 * const restrict retarray,
	46	gfc_array_i16 * const restrict array,
	47	const index_type * const restrict pdim)
644cb69f FXC	48	{
	49	index_type count[GFC_MAX_DIMENSIONS];
	50	index_type extent[GFC_MAX_DIMENSIONS];
	51	index_type sstride[GFC_MAX_DIMENSIONS];
	52	index_type dstride[GFC_MAX_DIMENSIONS];
64acfd99 JB	53	const GFC_INTEGER_16 * restrict base;
64acfd99 JB	54	GFC_INTEGER_16 * restrict dest;
644cb69f FXC	55	index_type rank;
	56	index_type n;
	57	index_type len;
	58	index_type delta;
	59	index_type dim;
	60
	61	/* Make dim zero based to avoid confusion. */
	62	dim = (*pdim) - 1;
	63	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	64
644cb69f FXC	65	len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
	66	delta = array->dim[dim].stride;
	67
	68	for (n = 0; n < dim; n++)
	69	{
	70	sstride[n] = array->dim[n].stride;
	71	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
80ee04b9 TK	72
	73	if (extent[n] < 0)
	74	extent[n] = 0;
644cb69f FXC	75	}
	76	for (n = dim; n < rank; n++)
	77	{
	78	sstride[n] = array->dim[n + 1].stride;
	79	extent[n] =
	80	array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
80ee04b9 TK	81
	82	if (extent[n] < 0)
	83	extent[n] = 0;
644cb69f FXC	84	}
	85
	86	if (retarray->data == NULL)
	87	{
80ee04b9 TK	88	size_t alloc_size;
80ee04b9 TK	89
644cb69f FXC	90	for (n = 0; n < rank; n++)
	91	{
	92	retarray->dim[n].lbound = 0;
	93	retarray->dim[n].ubound = extent[n]-1;
	94	if (n == 0)
	95	retarray->dim[n].stride = 1;
	96	else
	97	retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
	98	}
	99
644cb69f FXC	100	retarray->offset = 0;
644cb69f FXC	101	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	102
	103	alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride
	104	* extent[rank-1];
	105
	106	if (alloc_size == 0)
	107	{
	108	/* Make sure we have a zero-sized array. */
	109	retarray->dim[0].lbound = 0;
	110	retarray->dim[0].ubound = -1;
	111	return;
	112	}
	113	else
	114	retarray->data = internal_malloc_size (alloc_size);
644cb69f FXC	115	}
	116	else
	117	{
644cb69f FXC	118	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	119	runtime_error ("rank of return array incorrect");
	120	}
	121
	122	for (n = 0; n < rank; n++)
	123	{
	124	count[n] = 0;
	125	dstride[n] = retarray->dim[n].stride;
	126	if (extent[n] <= 0)
	127	len = 0;
	128	}
	129
	130	base = array->data;
	131	dest = retarray->data;
	132
	133	while (base)
	134	{
64acfd99	135	const GFC_INTEGER_16 * restrict src;
644cb69f FXC	136	GFC_INTEGER_16 result;
	137	src = base;
	138	{
	139
	140	result = 1;
	141	if (len <= 0)
	142	*dest = 1;
	143	else
	144	{
	145	for (n = 0; n < len; n++, src += delta)
	146	{
	147
	148	result = src;
	149	}
	150	*dest = result;
	151	}
	152	}
	153	/* Advance to the next element. */
	154	count[0]++;
	155	base += sstride[0];
	156	dest += dstride[0];
	157	n = 0;
	158	while (count[n] == extent[n])
	159	{
	160	/* When we get to the end of a dimension, reset it and increment
	161	the next dimension. */
	162	count[n] = 0;
	163	/* We could precalculate these products, but this is a less
5d7adf7a	164	frequently used path so probably not worth it. */
644cb69f FXC	165	base -= sstride[n] * extent[n];
	166	dest -= dstride[n] * extent[n];
	167	n++;
	168	if (n == rank)
	169	{
	170	/* Break out of the look. */
	171	base = NULL;
	172	break;
	173	}
	174	else
	175	{
	176	count[n]++;
	177	base += sstride[n];
	178	dest += dstride[n];
	179	}
	180	}
	181	}
	182	}
	183
	184
64acfd99 JB	185	extern void mproduct_i16 (gfc_array_i16 * const restrict,
64acfd99 JB	186	gfc_array_i16 * const restrict, const index_type * const restrict,
28dc6b33	187	gfc_array_l1 * const restrict);
644cb69f FXC	188	export_proto(mproduct_i16);
	189
	190	void
64acfd99 JB	191	mproduct_i16 (gfc_array_i16 * const restrict retarray,
	192	gfc_array_i16 * const restrict array,
	193	const index_type * const restrict pdim,
28dc6b33	194	gfc_array_l1 * const restrict mask)
644cb69f FXC	195	{
	196	index_type count[GFC_MAX_DIMENSIONS];
	197	index_type extent[GFC_MAX_DIMENSIONS];
	198	index_type sstride[GFC_MAX_DIMENSIONS];
	199	index_type dstride[GFC_MAX_DIMENSIONS];
	200	index_type mstride[GFC_MAX_DIMENSIONS];
64acfd99 JB	201	GFC_INTEGER_16 * restrict dest;
64acfd99 JB	202	const GFC_INTEGER_16 * restrict base;
28dc6b33	203	const GFC_LOGICAL_1 * restrict mbase;
644cb69f FXC	204	int rank;
	205	int dim;
	206	index_type n;
	207	index_type len;
	208	index_type delta;
	209	index_type mdelta;
28dc6b33	210	int mask_kind;
644cb69f FXC	211
	212	dim = (*pdim) - 1;
	213	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	214
644cb69f FXC	215	len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
	216	if (len <= 0)
	217	return;
28dc6b33 TK	218
	219	mbase = mask->data;
	220
	221	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	222
	223	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	224	#ifdef HAVE_GFC_LOGICAL_16
	225	\|\| mask_kind == 16
	226	#endif
	227	)
	228	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	229	else
	230	runtime_error ("Funny sized logical array");
	231
644cb69f	232	delta = array->dim[dim].stride;
28dc6b33	233	mdelta = mask->dim[dim].stride * mask_kind;
644cb69f FXC	234
	235	for (n = 0; n < dim; n++)
	236	{
	237	sstride[n] = array->dim[n].stride;
28dc6b33	238	mstride[n] = mask->dim[n].stride * mask_kind;
644cb69f	239	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
80ee04b9 TK	240
	241	if (extent[n] < 0)
	242	extent[n] = 0;
	243
644cb69f FXC	244	}
	245	for (n = dim; n < rank; n++)
	246	{
	247	sstride[n] = array->dim[n + 1].stride;
28dc6b33	248	mstride[n] = mask->dim[n + 1].stride * mask_kind;
644cb69f FXC	249	extent[n] =
644cb69f FXC	250	array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
80ee04b9 TK	251
	252	if (extent[n] < 0)
	253	extent[n] = 0;
644cb69f FXC	254	}
	255
	256	if (retarray->data == NULL)
	257	{
80ee04b9 TK	258	size_t alloc_size;
80ee04b9 TK	259
644cb69f FXC	260	for (n = 0; n < rank; n++)
	261	{
	262	retarray->dim[n].lbound = 0;
	263	retarray->dim[n].ubound = extent[n]-1;
	264	if (n == 0)
	265	retarray->dim[n].stride = 1;
	266	else
	267	retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
	268	}
	269
80ee04b9 TK	270	alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride
	271	* extent[rank-1];
	272
644cb69f FXC	273	retarray->offset = 0;
644cb69f FXC	274	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	275
	276	if (alloc_size == 0)
	277	{
	278	/* Make sure we have a zero-sized array. */
	279	retarray->dim[0].lbound = 0;
	280	retarray->dim[0].ubound = -1;
	281	return;
	282	}
	283	else
	284	retarray->data = internal_malloc_size (alloc_size);
	285
644cb69f FXC	286	}
	287	else
	288	{
644cb69f FXC	289	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	290	runtime_error ("rank of return array incorrect");
	291	}
	292
	293	for (n = 0; n < rank; n++)
	294	{
	295	count[n] = 0;
	296	dstride[n] = retarray->dim[n].stride;
	297	if (extent[n] <= 0)
	298	return;
	299	}
	300
	301	dest = retarray->data;
	302	base = array->data;
644cb69f FXC	303
	304	while (base)
	305	{
64acfd99	306	const GFC_INTEGER_16 * restrict src;
28dc6b33	307	const GFC_LOGICAL_1 * restrict msrc;
644cb69f FXC	308	GFC_INTEGER_16 result;
	309	src = base;
	310	msrc = mbase;
	311	{
	312
	313	result = 1;
	314	if (len <= 0)
	315	*dest = 1;
	316	else
	317	{
	318	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	319	{
	320
	321	if (*msrc)
	322	result = src;
	323	}
	324	*dest = result;
	325	}
	326	}
	327	/* Advance to the next element. */
	328	count[0]++;
	329	base += sstride[0];
	330	mbase += mstride[0];
	331	dest += dstride[0];
	332	n = 0;
	333	while (count[n] == extent[n])
	334	{
	335	/* When we get to the end of a dimension, reset it and increment
	336	the next dimension. */
	337	count[n] = 0;
	338	/* We could precalculate these products, but this is a less
5d7adf7a	339	frequently used path so probably not worth it. */
644cb69f FXC	340	base -= sstride[n] * extent[n];
	341	mbase -= mstride[n] * extent[n];
	342	dest -= dstride[n] * extent[n];
	343	n++;
	344	if (n == rank)
	345	{
	346	/* Break out of the look. */
	347	base = NULL;
	348	break;
	349	}
	350	else
	351	{
	352	count[n]++;
	353	base += sstride[n];
	354	mbase += mstride[n];
	355	dest += dstride[n];
	356	}
	357	}
	358	}
	359	}
	360
97a62038 TK	361
	362	extern void sproduct_i16 (gfc_array_i16 * const restrict,
	363	gfc_array_i16 * const restrict, const index_type * const restrict,
	364	GFC_LOGICAL_4 *);
	365	export_proto(sproduct_i16);
	366
	367	void
	368	sproduct_i16 (gfc_array_i16 * const restrict retarray,
	369	gfc_array_i16 * const restrict array,
	370	const index_type * const restrict pdim,
	371	GFC_LOGICAL_4 * mask)
	372	{
	373	index_type rank;
	374	index_type n;
	375	index_type dstride;
	376	GFC_INTEGER_16 *dest;
	377
	378	if (*mask)
	379	{
	380	product_i16 (retarray, array, pdim);
	381	return;
	382	}
	383	rank = GFC_DESCRIPTOR_RANK (array);
	384	if (rank <= 0)
	385	runtime_error ("Rank of array needs to be > 0");
	386
	387	if (retarray->data == NULL)
	388	{
	389	retarray->dim[0].lbound = 0;
	390	retarray->dim[0].ubound = rank-1;
	391	retarray->dim[0].stride = 1;
	392	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	393	retarray->offset = 0;
	394	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
	395	}
	396	else
	397	{
	398	if (GFC_DESCRIPTOR_RANK (retarray) != 1)
	399	runtime_error ("rank of return array does not equal 1");
	400
	401	if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
	402	runtime_error ("dimension of return array incorrect");
97a62038 TK	403	}
	404
	405	dstride = retarray->dim[0].stride;
	406	dest = retarray->data;
	407
	408	for (n = 0; n < rank; n++)
	409	dest[n * dstride] = 1 ;
	410	}
	411
644cb69f	412	#endif