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

/* Implementation of the MAXLOC 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_16) && defined (HAVE_GFC_INTEGER_4)


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

void
maxloc0_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 maxval;

  maxval = (-GFC_INTEGER_16_HUGE-1);

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

  if (*base > maxval || !dest[0])
    {
      maxval = *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 mmaxloc0_4_i16 (gfc_array_i4 * const restrict, 
	gfc_array_i16 * const restrict, gfc_array_l4 * const restrict);
export_proto(mmaxloc0_4_i16);

void
mmaxloc0_4_i16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i16 * const restrict array,
	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 mstride[GFC_MAX_DIMENSIONS];
  index_type dstride;
  GFC_INTEGER_4 *dest;
  const GFC_INTEGER_16 *base;
  GFC_LOGICAL_4 *mbase;
  int 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;
      mstride[n] = mask->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;
  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;
      mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
    }


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

  GFC_INTEGER_16 maxval;

  maxval = (-GFC_INTEGER_16_HUGE-1);

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

  if (*mbase && (*base > maxval || !dest[0]))
    {
      maxval = *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 smaxloc0_4_i16 (gfc_array_i4 * const restrict, 
	gfc_array_i16 * const restrict, GFC_LOGICAL_4 *);
export_proto(smaxloc0_4_i16);

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