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

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


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


extern void minloc0_4_i16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i16 * const restrict array);
export_proto(minloc0_4_i16);

void
minloc0_4_i16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i16 * 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_16 *base;
  GFC_INTEGER_4 *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)
    {
      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_4) * 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++)
    {
      sstride[n] = array->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
      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_16 minval;

  minval = GFC_INTEGER_16_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_i16 (gfc_array_i4 * const restrict, 
	gfc_array_i16 * const restrict, gfc_array_l1 * const restrict);
export_proto(mminloc0_4_i16);

void
mminloc0_4_i16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i16 * 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_16 *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)
    {
      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_4) * 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");
    }

  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 = retarray->dim[0].stride;
  dest = retarray->data;
  for (n = 0; n < rank; 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;
      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_16 minval;

  minval = GFC_INTEGER_16_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_i16 (gfc_array_i4 * const restrict, 
	gfc_array_i16 * const restrict, GFC_LOGICAL_4 *);
export_proto(sminloc0_4_i16);

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

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