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

/* Implementation of the MINLOC 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 <float.h>
#include <limits.h>
#include "libgfortran.h"


#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)


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

void
minloc1_4_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * const restrict array, 
	const index_type * const restrict pdim)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_INTEGER_4 * restrict base;
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;

  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  /* TODO:  It should be a front end job to correctly set the strides.  */

  if (array->dim[0].stride == 0)
    array->dim[0].stride = 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;
    }
  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 (retarray->data == NULL)
    {
      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->data
	 = internal_malloc_size (sizeof (GFC_INTEGER_4)
		 		 * retarray->dim[rank-1].stride
				 * extent[rank-1]);
      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
    }
  else
    {
      if (retarray->dim[0].stride == 0)
	retarray->dim[0].stride = 1;

      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_4 * restrict src;
      GFC_INTEGER_4 result;
      src = base;
      {

  GFC_INTEGER_4 minval;
  minval = GFC_INTEGER_4_HUGE;
  result = 1;
        if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

  if (*src < minval)
    {
      minval = *src;
      result = (GFC_INTEGER_4)n + 1;
    }
          }
	    *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 proabably 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 mminloc1_4_i4 (gfc_array_i4 * const restrict, 
	gfc_array_i4 * const restrict, const index_type * const restrict,
	gfc_array_l4 * const restrict);
export_proto(mminloc1_4_i4);

void
mminloc1_4_i4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i4 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l4 * const restrict mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_4 * restrict dest;
  const GFC_INTEGER_4 * restrict base;
  const GFC_LOGICAL_4 * restrict mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;

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

  /* TODO:  It should be a front end job to correctly set the strides.  */

  if (array->dim[0].stride == 0)
    array->dim[0].stride = 1;

  if (mask->dim[0].stride == 0)
    mask->dim[0].stride = 1;

  len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  if (len <= 0)
    return;
  delta = array->dim[dim].stride;
  mdelta = mask->dim[dim].stride;

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

  if (retarray->data == NULL)
    {
      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->data
	 = internal_malloc_size (sizeof (GFC_INTEGER_4)
		 		 * retarray->dim[rank-1].stride
				 * extent[rank-1]);
      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
    }
  else
    {
      if (retarray->dim[0].stride == 0)
	retarray->dim[0].stride = 1;

      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;
  mbase = mask->data;

  if (GFC_DESCRIPTOR_SIZE (mask) != 4)
    {
      /* This allows the same loop to be used for all logical types.  */
      assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
      for (n = 0; n < rank; n++)
        mstride[n] <<= 1;
      mdelta <<= 1;
      mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
    }

  while (base)
    {
      const GFC_INTEGER_4 * restrict src;
      const GFC_LOGICAL_4 * restrict msrc;
      GFC_INTEGER_4 result;
      src = base;
      msrc = mbase;
      {

  GFC_INTEGER_4 minval;
  minval = GFC_INTEGER_4_HUGE;
  result = 1;
        if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

  if (*msrc && *src < minval)
    {
      minval = *src;
      result = (GFC_INTEGER_4)n + 1;
    }
              }
	    *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 proabably 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];
            }
        }
    }
}

#endif
Commit	Line	Data
6de9cd9a DN	1	/* Implementation of the MINLOC intrinsic
	2	Copyright 2002 Free Software Foundation, Inc.
	3	Contributed by Paul Brook <paul@nowt.org>
	4
57dea9f6	5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
6de9cd9a DN	6
6de9cd9a DN	7	Libgfortran is free software; you can redistribute it and/or
57dea9f6	8	modify it under the terms of the GNU General Public
6de9cd9a	9	License as published by the Free Software Foundation; either
57dea9f6 TM	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.)
6de9cd9a DN	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
57dea9f6	24	GNU General Public License for more details.
6de9cd9a	25
57dea9f6 TM	26	You should have received a copy of the GNU General Public
57dea9f6 TM	27	License along with libgfortran; see the file COPYING. If not,
fe2ae685 KC	28	write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
fe2ae685 KC	29	Boston, MA 02110-1301, USA. */
6de9cd9a DN	30
	31	#include "config.h"
	32	#include <stdlib.h>
	33	#include <assert.h>
	34	#include <float.h>
	35	#include <limits.h>
	36	#include "libgfortran.h"
	37
7d7b8bfe	38
644cb69f FXC	39	#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
	40
	41
64acfd99 JB	42	extern void minloc1_4_i4 (gfc_array_i4 * const restrict,
64acfd99 JB	43	gfc_array_i4 * const restrict, const index_type * const restrict);
7f68c75f	44	export_proto(minloc1_4_i4);
7d7b8bfe	45
6de9cd9a	46	void
64acfd99 JB	47	minloc1_4_i4 (gfc_array_i4 * const restrict retarray,
	48	gfc_array_i4 * const restrict array,
	49	const index_type * const restrict pdim)
6de9cd9a	50	{
e33e218b TK	51	index_type count[GFC_MAX_DIMENSIONS];
	52	index_type extent[GFC_MAX_DIMENSIONS];
	53	index_type sstride[GFC_MAX_DIMENSIONS];
	54	index_type dstride[GFC_MAX_DIMENSIONS];
64acfd99 JB	55	const GFC_INTEGER_4 * restrict base;
64acfd99 JB	56	GFC_INTEGER_4 * restrict dest;
6de9cd9a DN	57	index_type rank;
	58	index_type n;
	59	index_type len;
	60	index_type delta;
	61	index_type dim;
	62
	63	/* Make dim zero based to avoid confusion. */
	64	dim = (*pdim) - 1;
	65	rank = GFC_DESCRIPTOR_RANK (array) - 1;
e33e218b TK	66
	67	/* TODO: It should be a front end job to correctly set the strides. */
	68
6de9cd9a DN	69	if (array->dim[0].stride == 0)
6de9cd9a DN	70	array->dim[0].stride = 1;
6de9cd9a DN	71
	72	len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
	73	delta = array->dim[dim].stride;
	74
	75	for (n = 0; n < dim; n++)
	76	{
	77	sstride[n] = array->dim[n].stride;
	78	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
	79	}
	80	for (n = dim; n < rank; n++)
	81	{
	82	sstride[n] = array->dim[n + 1].stride;
	83	extent[n] =
	84	array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
	85	}
	86
6c167c45 VL	87	if (retarray->data == NULL)
	88	{
	89	for (n = 0; n < rank; n++)
	90	{
	91	retarray->dim[n].lbound = 0;
	92	retarray->dim[n].ubound = extent[n]-1;
	93	if (n == 0)
	94	retarray->dim[n].stride = 1;
	95	else
	96	retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
	97	}
	98
07d3cebe RH	99	retarray->data
	100	= internal_malloc_size (sizeof (GFC_INTEGER_4)
	101	* retarray->dim[rank-1].stride
	102	* extent[rank-1]);
efd4dc1a	103	retarray->offset = 0;
50dd63a9	104	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
6c167c45	105	}
50dd63a9 TK	106	else
	107	{
	108	if (retarray->dim[0].stride == 0)
	109	retarray->dim[0].stride = 1;
	110
	111	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	112	runtime_error ("rank of return array incorrect");
	113	}
	114
6de9cd9a DN	115	for (n = 0; n < rank; n++)
	116	{
	117	count[n] = 0;
	118	dstride[n] = retarray->dim[n].stride;
	119	if (extent[n] <= 0)
	120	len = 0;
	121	}
	122
	123	base = array->data;
	124	dest = retarray->data;
	125
	126	while (base)
	127	{
64acfd99	128	const GFC_INTEGER_4 * restrict src;
6de9cd9a DN	129	GFC_INTEGER_4 result;
	130	src = base;
	131	{
	132
	133	GFC_INTEGER_4 minval;
	134	minval = GFC_INTEGER_4_HUGE;
	135	result = 1;
	136	if (len <= 0)
	137	*dest = 0;
	138	else
	139	{
	140	for (n = 0; n < len; n++, src += delta)
	141	{
	142
	143	if (*src < minval)
	144	{
	145	minval = *src;
	146	result = (GFC_INTEGER_4)n + 1;
	147	}
	148	}
	149	*dest = result;
	150	}
	151	}
	152	/* Advance to the next element. */
	153	count[0]++;
	154	base += sstride[0];
	155	dest += dstride[0];
	156	n = 0;
	157	while (count[n] == extent[n])
	158	{
	159	/* When we get to the end of a dimension, reset it and increment
	160	the next dimension. */
	161	count[n] = 0;
	162	/* We could precalculate these products, but this is a less
	163	frequently used path so proabably not worth it. */
	164	base -= sstride[n] * extent[n];
	165	dest -= dstride[n] * extent[n];
	166	n++;
	167	if (n == rank)
	168	{
	169	/* Break out of the look. */
	170	base = NULL;
	171	break;
	172	}
	173	else
	174	{
	175	count[n]++;
	176	base += sstride[n];
	177	dest += dstride[n];
	178	}
	179	}
	180	}
	181	}
	182
7d7b8bfe	183
64acfd99 JB	184	extern void mminloc1_4_i4 (gfc_array_i4 * const restrict,
	185	gfc_array_i4 * const restrict, const index_type * const restrict,
	186	gfc_array_l4 * const restrict);
7f68c75f	187	export_proto(mminloc1_4_i4);
7d7b8bfe	188
6de9cd9a	189	void
64acfd99 JB	190	mminloc1_4_i4 (gfc_array_i4 * const restrict retarray,
	191	gfc_array_i4 * const restrict array,
	192	const index_type * const restrict pdim,
	193	gfc_array_l4 * const restrict mask)
6de9cd9a	194	{
e33e218b TK	195	index_type count[GFC_MAX_DIMENSIONS];
	196	index_type extent[GFC_MAX_DIMENSIONS];
	197	index_type sstride[GFC_MAX_DIMENSIONS];
	198	index_type dstride[GFC_MAX_DIMENSIONS];
	199	index_type mstride[GFC_MAX_DIMENSIONS];
64acfd99 JB	200	GFC_INTEGER_4 * restrict dest;
	201	const GFC_INTEGER_4 * restrict base;
	202	const GFC_LOGICAL_4 * restrict mbase;
6de9cd9a DN	203	int rank;
	204	int dim;
	205	index_type n;
	206	index_type len;
	207	index_type delta;
	208	index_type mdelta;
	209
	210	dim = (*pdim) - 1;
	211	rank = GFC_DESCRIPTOR_RANK (array) - 1;
e33e218b TK	212
	213	/* TODO: It should be a front end job to correctly set the strides. */
	214
6de9cd9a DN	215	if (array->dim[0].stride == 0)
6de9cd9a DN	216	array->dim[0].stride = 1;
6de9cd9a	217
c6abe94d TK	218	if (mask->dim[0].stride == 0)
	219	mask->dim[0].stride = 1;
	220
6de9cd9a DN	221	len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
	222	if (len <= 0)
	223	return;
	224	delta = array->dim[dim].stride;
	225	mdelta = mask->dim[dim].stride;
	226
	227	for (n = 0; n < dim; n++)
	228	{
	229	sstride[n] = array->dim[n].stride;
	230	mstride[n] = mask->dim[n].stride;
	231	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
	232	}
	233	for (n = dim; n < rank; n++)
	234	{
	235	sstride[n] = array->dim[n + 1].stride;
	236	mstride[n] = mask->dim[n + 1].stride;
	237	extent[n] =
	238	array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
	239	}
	240
50dd63a9 TK	241	if (retarray->data == NULL)
	242	{
	243	for (n = 0; n < rank; n++)
	244	{
	245	retarray->dim[n].lbound = 0;
	246	retarray->dim[n].ubound = extent[n]-1;
	247	if (n == 0)
	248	retarray->dim[n].stride = 1;
	249	else
	250	retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
	251	}
	252
	253	retarray->data
	254	= internal_malloc_size (sizeof (GFC_INTEGER_4)
	255	* retarray->dim[rank-1].stride
	256	* extent[rank-1]);
efd4dc1a	257	retarray->offset = 0;
50dd63a9 TK	258	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	259	}
	260	else
	261	{
	262	if (retarray->dim[0].stride == 0)
	263	retarray->dim[0].stride = 1;
	264
	265	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	266	runtime_error ("rank of return array incorrect");
	267	}
	268
6de9cd9a DN	269	for (n = 0; n < rank; n++)
	270	{
	271	count[n] = 0;
	272	dstride[n] = retarray->dim[n].stride;
	273	if (extent[n] <= 0)
	274	return;
	275	}
	276
	277	dest = retarray->data;
	278	base = array->data;
	279	mbase = mask->data;
	280
	281	if (GFC_DESCRIPTOR_SIZE (mask) != 4)
	282	{
	283	/* This allows the same loop to be used for all logical types. */
	284	assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
	285	for (n = 0; n < rank; n++)
	286	mstride[n] <<= 1;
	287	mdelta <<= 1;
	288	mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
	289	}
	290
	291	while (base)
	292	{
64acfd99 JB	293	const GFC_INTEGER_4 * restrict src;
64acfd99 JB	294	const GFC_LOGICAL_4 * restrict msrc;
6de9cd9a DN	295	GFC_INTEGER_4 result;
	296	src = base;
	297	msrc = mbase;
	298	{
	299
	300	GFC_INTEGER_4 minval;
	301	minval = GFC_INTEGER_4_HUGE;
	302	result = 1;
	303	if (len <= 0)
	304	*dest = 0;
	305	else
	306	{
	307	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	308	{
	309
	310	if (msrc && src < minval)
	311	{
	312	minval = *src;
	313	result = (GFC_INTEGER_4)n + 1;
	314	}
	315	}
	316	*dest = result;
	317	}
	318	}
	319	/* Advance to the next element. */
	320	count[0]++;
	321	base += sstride[0];
	322	mbase += mstride[0];
	323	dest += dstride[0];
	324	n = 0;
	325	while (count[n] == extent[n])
	326	{
	327	/* When we get to the end of a dimension, reset it and increment
	328	the next dimension. */
	329	count[n] = 0;
	330	/* We could precalculate these products, but this is a less
	331	frequently used path so proabably not worth it. */
	332	base -= sstride[n] * extent[n];
	333	mbase -= mstride[n] * extent[n];
	334	dest -= dstride[n] * extent[n];
	335	n++;
	336	if (n == rank)
	337	{
	338	/* Break out of the look. */
	339	base = NULL;
	340	break;
	341	}
	342	else
	343	{
	344	count[n]++;
	345	base += sstride[n];
	346	mbase += mstride[n];
	347	dest += dstride[n];
	348	}
	349	}
	350	}
	351	}
	352
644cb69f	353	#endif