[thirdparty/gcc.git] / libgfortran / generated / maxloc0_4_i2.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 <limits.h>
#include "libgfortran.h"


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


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

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

  maxval = (-GFC_INTEGER_2_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_i2 (gfc_array_i4 * const restrict, 
	gfc_array_i2 * const restrict, gfc_array_l1 * const restrict);
export_proto(mmaxloc0_4_i2);

void
mmaxloc0_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)
    {
      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_2 maxval;

  maxval = (-GFC_INTEGER_2_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_i2 (gfc_array_i4 * const restrict, 
	gfc_array_i2 * const restrict, GFC_LOGICAL_4 *);
export_proto(smaxloc0_4_i2);

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