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

/* Implementation of the MINLOC intrinsic
   Copyright 2002, 2007, 2009 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 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"
#include <stdlib.h>
#include <assert.h>
#include <limits.h>


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


extern void minloc0_4_i2 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i2 * const restrict array);
export_proto(minloc0_4_i2);

void
minloc0_4_i2 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i2 * const restrict array)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride;
  const GFC_INTEGER_2 *base;
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;

  rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->data == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
	                        "MINLOC");
    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->data;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      count[n] = 0;
      if (extent[n] <= 0)
	{
	  /* Set the return value.  */
	  for (n = 0; n < rank; n++)
	    dest[n * dstride] = 0;
	  return;
	}
    }

  base = array->data;

  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;
  {

  GFC_INTEGER_2 minval;

  minval = GFC_INTEGER_2_HUGE;

  while (base)
    {
      {
        /* Implementation start.  */

  if (*base < minval || !dest[0])
    {
      minval = *base;
      for (n = 0; n < rank; n++)
        dest[n * dstride] = count[n] + 1;
    }
        /* Implementation end.  */
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[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];
          n++;
          if (n == rank)
            {
              /* Break out of the loop.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
            }
        }
    }
  }
}


extern void mminloc0_4_i2 (gfc_array_i4 * const restrict, 
	gfc_array_i2 * const restrict, gfc_array_l1 * const restrict);
export_proto(mminloc0_4_i2);

void
mminloc0_4_i2 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i2 * const restrict array,
	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 mstride[GFC_MAX_DIMENSIONS];
  index_type dstride;
  GFC_INTEGER_4 *dest;
  const GFC_INTEGER_2 *base;
  GFC_LOGICAL_1 *mbase;
  int rank;
  index_type n;
  int mask_kind;

  rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->data == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
	{

	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
				  "MINLOC");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
				  "MASK argument", "MINLOC");
	}
    }

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  mbase = mask->data;

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

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->data;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      count[n] = 0;
      if (extent[n] <= 0)
	{
	  /* Set the return value.  */
	  for (n = 0; n < rank; n++)
	    dest[n * dstride] = 0;
	  return;
	}
    }

  base = array->data;

  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;
  {

  GFC_INTEGER_2 minval;

  minval = GFC_INTEGER_2_HUGE;

  while (base)
    {
      {
        /* Implementation start.  */

  if (*mbase && (*base < minval || !dest[0]))
    {
      minval = *base;
      for (n = 0; n < rank; n++)
        dest[n * dstride] = count[n] + 1;
    }
        /* Implementation end.  */
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[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];
          n++;
          if (n == rank)
            {
              /* Break out of the loop.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              mbase += mstride[n];
            }
        }
    }
  }
}


extern void sminloc0_4_i2 (gfc_array_i4 * const restrict, 
	gfc_array_i2 * const restrict, GFC_LOGICAL_4 *);
export_proto(sminloc0_4_i2);

void
sminloc0_4_i2 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i2 * const restrict array,
	GFC_LOGICAL_4 * mask)
{
  index_type rank;
  index_type dstride;
  index_type n;
  GFC_INTEGER_4 *dest;

  if (*mask)
    {
      minloc0_4_i2 (retarray, array);
      return;
    }

  rank = GFC_DESCRIPTOR_RANK (array);

  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->data == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
    }
  else if (unlikely (compile_options.bounds_check))
    {
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
			       "MINLOC");
    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->data;
  for (n = 0; n<rank; n++)
    dest[n * dstride] = 0 ;
}
#endif
Commit	Line	Data
567c915b	1	/* Implementation of the MINLOC intrinsic
748086b7	2	Copyright 2002, 2007, 2009 Free Software Foundation, Inc.
567c915b TK	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
748086b7	10	version 3 of the License, or (at your option) any later version.
567c915b TK	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/>. */
567c915b	25
36ae8a61	26	#include "libgfortran.h"
567c915b TK	27	#include <stdlib.h>
567c915b TK	28	#include <assert.h>
567c915b	29	#include <limits.h>
567c915b TK	30
	31
	32	#if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_4)
	33
	34
	35	extern void minloc0_4_i2 (gfc_array_i4 * const restrict retarray,
	36	gfc_array_i2 * const restrict array);
	37	export_proto(minloc0_4_i2);
	38
	39	void
	40	minloc0_4_i2 (gfc_array_i4 * const restrict retarray,
	41	gfc_array_i2 * const restrict array)
	42	{
	43	index_type count[GFC_MAX_DIMENSIONS];
	44	index_type extent[GFC_MAX_DIMENSIONS];
	45	index_type sstride[GFC_MAX_DIMENSIONS];
	46	index_type dstride;
	47	const GFC_INTEGER_2 *base;
5863aacf	48	GFC_INTEGER_4 * restrict dest;
567c915b TK	49	index_type rank;
	50	index_type n;
	51
	52	rank = GFC_DESCRIPTOR_RANK (array);
	53	if (rank <= 0)
	54	runtime_error ("Rank of array needs to be > 0");
	55
	56	if (retarray->data == NULL)
	57	{
dfb55fdc	58	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
567c915b TK	59	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	60	retarray->offset = 0;
	61	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
	62	}
	63	else
	64	{
9731c4a3	65	if (unlikely (compile_options.bounds_check))
16bff921 TK	66	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
16bff921 TK	67	"MINLOC");
567c915b TK	68	}
567c915b TK	69
dfb55fdc	70	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
567c915b TK	71	dest = retarray->data;
	72	for (n = 0; n < rank; n++)
	73	{
dfb55fdc TK	74	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
dfb55fdc TK	75	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
567c915b TK	76	count[n] = 0;
	77	if (extent[n] <= 0)
	78	{
	79	/* Set the return value. */
	80	for (n = 0; n < rank; n++)
	81	dest[n * dstride] = 0;
	82	return;
	83	}
	84	}
	85
	86	base = array->data;
	87
	88	/* Initialize the return value. */
	89	for (n = 0; n < rank; n++)
	90	dest[n * dstride] = 0;
	91	{
	92
	93	GFC_INTEGER_2 minval;
	94
	95	minval = GFC_INTEGER_2_HUGE;
	96
	97	while (base)
	98	{
	99	{
	100	/* Implementation start. */
	101
	102	if (*base < minval \|\| !dest[0])
	103	{
	104	minval = *base;
	105	for (n = 0; n < rank; n++)
	106	dest[n * dstride] = count[n] + 1;
	107	}
	108	/* Implementation end. */
	109	}
	110	/* Advance to the next element. */
	111	count[0]++;
	112	base += sstride[0];
	113	n = 0;
	114	while (count[n] == extent[n])
	115	{
	116	/* When we get to the end of a dimension, reset it and increment
	117	the next dimension. */
	118	count[n] = 0;
	119	/* We could precalculate these products, but this is a less
	120	frequently used path so probably not worth it. */
	121	base -= sstride[n] * extent[n];
	122	n++;
	123	if (n == rank)
	124	{
	125	/* Break out of the loop. */
	126	base = NULL;
	127	break;
	128	}
	129	else
	130	{
	131	count[n]++;
	132	base += sstride[n];
	133	}
	134	}
	135	}
	136	}
	137	}
	138
	139
140	extern void mminloc0_4_i2 (gfc_array_i4 * const restrict,
28dc6b33	141	gfc_array_i2 * const restrict, gfc_array_l1 * const restrict);
567c915b TK	142	export_proto(mminloc0_4_i2);
	143
	144	void
	145	mminloc0_4_i2 (gfc_array_i4 * const restrict retarray,
	146	gfc_array_i2 * const restrict array,
28dc6b33	147	gfc_array_l1 * const restrict mask)
567c915b TK	148	{
	149	index_type count[GFC_MAX_DIMENSIONS];
	150	index_type extent[GFC_MAX_DIMENSIONS];
	151	index_type sstride[GFC_MAX_DIMENSIONS];
	152	index_type mstride[GFC_MAX_DIMENSIONS];
	153	index_type dstride;
	154	GFC_INTEGER_4 *dest;
	155	const GFC_INTEGER_2 *base;
28dc6b33	156	GFC_LOGICAL_1 *mbase;
567c915b TK	157	int rank;
567c915b TK	158	index_type n;
28dc6b33	159	int mask_kind;
567c915b TK	160
	161	rank = GFC_DESCRIPTOR_RANK (array);
	162	if (rank <= 0)
	163	runtime_error ("Rank of array needs to be > 0");
	164
	165	if (retarray->data == NULL)
	166	{
dfb55fdc	167	GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
567c915b TK	168	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	169	retarray->offset = 0;
	170	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
	171	}
	172	else
	173	{
9731c4a3	174	if (unlikely (compile_options.bounds_check))
fd6590f8	175	{
16bff921 TK	176
	177	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	178	"MINLOC");
	179	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	180	"MASK argument", "MINLOC");
fd6590f8	181	}
567c915b TK	182	}
567c915b TK	183
28dc6b33 TK	184	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	185
	186	mbase = mask->data;
	187
	188	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	189	#ifdef HAVE_GFC_LOGICAL_16
	190	\|\| mask_kind == 16
	191	#endif
	192	)
	193	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	194	else
	195	runtime_error ("Funny sized logical array");
	196
dfb55fdc	197	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
567c915b TK	198	dest = retarray->data;
	199	for (n = 0; n < rank; n++)
	200	{
dfb55fdc TK	201	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	202	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	203	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
567c915b TK	204	count[n] = 0;
	205	if (extent[n] <= 0)
	206	{
	207	/* Set the return value. */
	208	for (n = 0; n < rank; n++)
	209	dest[n * dstride] = 0;
	210	return;
	211	}
	212	}
	213
	214	base = array->data;
567c915b TK	215
	216	/* Initialize the return value. */
	217	for (n = 0; n < rank; n++)
	218	dest[n * dstride] = 0;
	219	{
	220
	221	GFC_INTEGER_2 minval;
	222
	223	minval = GFC_INTEGER_2_HUGE;
	224
	225	while (base)
	226	{
	227	{
	228	/* Implementation start. */
	229
	230	if (mbase && (base < minval \|\| !dest[0]))
	231	{
	232	minval = *base;
	233	for (n = 0; n < rank; n++)
	234	dest[n * dstride] = count[n] + 1;
	235	}
	236	/* Implementation end. */
	237	}
	238	/* Advance to the next element. */
	239	count[0]++;
	240	base += sstride[0];
	241	mbase += mstride[0];
	242	n = 0;
	243	while (count[n] == extent[n])
	244	{
	245	/* When we get to the end of a dimension, reset it and increment
	246	the next dimension. */
	247	count[n] = 0;
	248	/* We could precalculate these products, but this is a less
	249	frequently used path so probably not worth it. */
	250	base -= sstride[n] * extent[n];
	251	mbase -= mstride[n] * extent[n];
	252	n++;
	253	if (n == rank)
	254	{
	255	/* Break out of the loop. */
	256	base = NULL;
	257	break;
	258	}
	259	else
	260	{
	261	count[n]++;
	262	base += sstride[n];
	263	mbase += mstride[n];
	264	}
	265	}
	266	}
	267	}
	268	}
	269
	270
	271	extern void sminloc0_4_i2 (gfc_array_i4 * const restrict,
	272	gfc_array_i2 * const restrict, GFC_LOGICAL_4 *);
	273	export_proto(sminloc0_4_i2);
	274
	275	void
	276	sminloc0_4_i2 (gfc_array_i4 * const restrict retarray,
	277	gfc_array_i2 * const restrict array,
	278	GFC_LOGICAL_4 * mask)
279	{
280	index_type rank;
281	index_type dstride;
282	index_type n;
283	GFC_INTEGER_4 *dest;
284
285	if (*mask)
286	{
287	minloc0_4_i2 (retarray, array);
288	return;
289	}
290
291	rank = GFC_DESCRIPTOR_RANK (array);
292
293	if (rank <= 0)
294	runtime_error ("Rank of array needs to be > 0");
295
296	if (retarray->data == NULL)
297	{
dfb55fdc	298	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
567c915b TK	299	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	300	retarray->offset = 0;
	301	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
	302	}
16bff921	303	else if (unlikely (compile_options.bounds_check))
567c915b	304	{
16bff921 TK	305	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
16bff921 TK	306	"MINLOC");
567c915b TK	307	}
567c915b TK	308
dfb55fdc	309	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
567c915b TK	310	dest = retarray->data;
	311	for (n = 0; n<rank; n++)
	312	dest[n * dstride] = 0 ;
	313	}
	314	#endif