[thirdparty/gcc.git] / libgfortran / generated / maxloc1_8_r4.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_REAL_4) && defined (HAVE_GFC_INTEGER_8)


extern void maxloc1_8_r4 (gfc_array_i8 *, gfc_array_r4 *, index_type *);
export_proto(maxloc1_8_r4);

void
maxloc1_8_r4 (gfc_array_i8 *retarray, gfc_array_r4 *array, index_type *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];
  GFC_REAL_4 *base;
  GFC_INTEGER_8 *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_8)
		 		 * 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)
    {
      GFC_REAL_4 *src;
      GFC_INTEGER_8 result;
      src = base;
      {

  GFC_REAL_4 maxval;
  maxval = -GFC_REAL_4_HUGE;
  result = 1;
        if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

  if (*src > maxval)
    {
      maxval = *src;
      result = (GFC_INTEGER_8)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 mmaxloc1_8_r4 (gfc_array_i8 *, gfc_array_r4 *, index_type *,
					       gfc_array_l4 *);
export_proto(mmaxloc1_8_r4);

void
mmaxloc1_8_r4 (gfc_array_i8 * retarray, gfc_array_r4 * array,
				  index_type *pdim, gfc_array_l4 * 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_8 *dest;
  GFC_REAL_4 *base;
  GFC_LOGICAL_4 *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_8)
		 		 * 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)
    {
      GFC_REAL_4 *src;
      GFC_LOGICAL_4 *msrc;
      GFC_INTEGER_8 result;
      src = base;
      msrc = mbase;
      {

  GFC_REAL_4 maxval;
  maxval = -GFC_REAL_4_HUGE;
  result = 1;
        if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

  if (*msrc && *src > maxval)
    {
      maxval = *src;
      result = (GFC_INTEGER_8)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 MAXLOC 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_REAL_4) && defined (HAVE_GFC_INTEGER_8)
	40
	41
7f68c75f RH	42	extern void maxloc1_8_r4 (gfc_array_i8 , gfc_array_r4 , index_type *);
7f68c75f RH	43	export_proto(maxloc1_8_r4);
7d7b8bfe	44
6de9cd9a	45	void
7f68c75f	46	maxloc1_8_r4 (gfc_array_i8 retarray, gfc_array_r4 array, index_type *pdim)
6de9cd9a	47	{
e33e218b TK	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[GFC_MAX_DIMENSIONS];
6de9cd9a DN	52	GFC_REAL_4 *base;
	53	GFC_INTEGER_8 *dest;
	54	index_type rank;
	55	index_type n;
	56	index_type len;
	57	index_type delta;
	58	index_type dim;
	59
	60	/* Make dim zero based to avoid confusion. */
	61	dim = (*pdim) - 1;
	62	rank = GFC_DESCRIPTOR_RANK (array) - 1;
e33e218b TK	63
	64	/* TODO: It should be a front end job to correctly set the strides. */
	65
6de9cd9a DN	66	if (array->dim[0].stride == 0)
6de9cd9a DN	67	array->dim[0].stride = 1;
6de9cd9a DN	68
	69	len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
	70	delta = array->dim[dim].stride;
	71
	72	for (n = 0; n < dim; n++)
	73	{
	74	sstride[n] = array->dim[n].stride;
	75	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
	76	}
	77	for (n = dim; n < rank; n++)
	78	{
	79	sstride[n] = array->dim[n + 1].stride;
	80	extent[n] =
	81	array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
	82	}
	83
6c167c45 VL	84	if (retarray->data == NULL)
	85	{
	86	for (n = 0; n < rank; n++)
	87	{
	88	retarray->dim[n].lbound = 0;
	89	retarray->dim[n].ubound = extent[n]-1;
	90	if (n == 0)
	91	retarray->dim[n].stride = 1;
	92	else
	93	retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
	94	}
	95
07d3cebe RH	96	retarray->data
	97	= internal_malloc_size (sizeof (GFC_INTEGER_8)
	98	* retarray->dim[rank-1].stride
	99	* extent[rank-1]);
efd4dc1a	100	retarray->offset = 0;
50dd63a9	101	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
6c167c45	102	}
50dd63a9 TK	103	else
	104	{
	105	if (retarray->dim[0].stride == 0)
	106	retarray->dim[0].stride = 1;
	107
	108	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	109	runtime_error ("rank of return array incorrect");
	110	}
	111
6de9cd9a DN	112	for (n = 0; n < rank; n++)
	113	{
	114	count[n] = 0;
	115	dstride[n] = retarray->dim[n].stride;
	116	if (extent[n] <= 0)
	117	len = 0;
	118	}
	119
	120	base = array->data;
	121	dest = retarray->data;
	122
	123	while (base)
	124	{
	125	GFC_REAL_4 *src;
	126	GFC_INTEGER_8 result;
	127	src = base;
	128	{
	129
	130	GFC_REAL_4 maxval;
	131	maxval = -GFC_REAL_4_HUGE;
	132	result = 1;
	133	if (len <= 0)
	134	*dest = 0;
	135	else
	136	{
	137	for (n = 0; n < len; n++, src += delta)
	138	{
	139
	140	if (*src > maxval)
	141	{
	142	maxval = *src;
	143	result = (GFC_INTEGER_8)n + 1;
	144	}
	145	}
	146	*dest = result;
	147	}
	148	}
	149	/* Advance to the next element. */
	150	count[0]++;
	151	base += sstride[0];
	152	dest += dstride[0];
	153	n = 0;
	154	while (count[n] == extent[n])
	155	{
	156	/* When we get to the end of a dimension, reset it and increment
	157	the next dimension. */
	158	count[n] = 0;
	159	/* We could precalculate these products, but this is a less
	160	frequently used path so proabably not worth it. */
	161	base -= sstride[n] * extent[n];
	162	dest -= dstride[n] * extent[n];
	163	n++;
	164	if (n == rank)
	165	{
	166	/* Break out of the look. */
	167	base = NULL;
	168	break;
	169	}
	170	else
	171	{
	172	count[n]++;
	173	base += sstride[n];
	174	dest += dstride[n];
	175	}
176	}
177	}
178	}
179
7d7b8bfe	180
7f68c75f RH	181	extern void mmaxloc1_8_r4 (gfc_array_i8 , gfc_array_r4 , index_type *,
	182	gfc_array_l4 *);
	183	export_proto(mmaxloc1_8_r4);
7d7b8bfe	184
6de9cd9a	185	void
7f68c75f RH	186	mmaxloc1_8_r4 (gfc_array_i8 * retarray, gfc_array_r4 * array,
7f68c75f RH	187	index_type pdim, gfc_array_l4 mask)
6de9cd9a	188	{
e33e218b TK	189	index_type count[GFC_MAX_DIMENSIONS];
	190	index_type extent[GFC_MAX_DIMENSIONS];
	191	index_type sstride[GFC_MAX_DIMENSIONS];
	192	index_type dstride[GFC_MAX_DIMENSIONS];
	193	index_type mstride[GFC_MAX_DIMENSIONS];
6de9cd9a DN	194	GFC_INTEGER_8 *dest;
	195	GFC_REAL_4 *base;
	196	GFC_LOGICAL_4 *mbase;
	197	int rank;
	198	int dim;
	199	index_type n;
	200	index_type len;
	201	index_type delta;
	202	index_type mdelta;
	203
	204	dim = (*pdim) - 1;
	205	rank = GFC_DESCRIPTOR_RANK (array) - 1;
e33e218b TK	206
	207	/* TODO: It should be a front end job to correctly set the strides. */
	208
6de9cd9a DN	209	if (array->dim[0].stride == 0)
6de9cd9a DN	210	array->dim[0].stride = 1;
6de9cd9a	211
c6abe94d TK	212	if (mask->dim[0].stride == 0)
	213	mask->dim[0].stride = 1;
	214
6de9cd9a DN	215	len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
	216	if (len <= 0)
	217	return;
	218	delta = array->dim[dim].stride;
	219	mdelta = mask->dim[dim].stride;
	220
	221	for (n = 0; n < dim; n++)
	222	{
	223	sstride[n] = array->dim[n].stride;
	224	mstride[n] = mask->dim[n].stride;
	225	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
	226	}
	227	for (n = dim; n < rank; n++)
	228	{
	229	sstride[n] = array->dim[n + 1].stride;
	230	mstride[n] = mask->dim[n + 1].stride;
	231	extent[n] =
	232	array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
	233	}
	234
50dd63a9 TK	235	if (retarray->data == NULL)
	236	{
	237	for (n = 0; n < rank; n++)
	238	{
	239	retarray->dim[n].lbound = 0;
	240	retarray->dim[n].ubound = extent[n]-1;
	241	if (n == 0)
	242	retarray->dim[n].stride = 1;
	243	else
	244	retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
	245	}
	246
	247	retarray->data
	248	= internal_malloc_size (sizeof (GFC_INTEGER_8)
	249	* retarray->dim[rank-1].stride
	250	* extent[rank-1]);
efd4dc1a	251	retarray->offset = 0;
50dd63a9 TK	252	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	253	}
	254	else
	255	{
	256	if (retarray->dim[0].stride == 0)
	257	retarray->dim[0].stride = 1;
	258
	259	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	260	runtime_error ("rank of return array incorrect");
	261	}
	262
6de9cd9a DN	263	for (n = 0; n < rank; n++)
	264	{
	265	count[n] = 0;
	266	dstride[n] = retarray->dim[n].stride;
	267	if (extent[n] <= 0)
	268	return;
	269	}
	270
	271	dest = retarray->data;
	272	base = array->data;
	273	mbase = mask->data;
	274
	275	if (GFC_DESCRIPTOR_SIZE (mask) != 4)
	276	{
	277	/* This allows the same loop to be used for all logical types. */
	278	assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
	279	for (n = 0; n < rank; n++)
	280	mstride[n] <<= 1;
	281	mdelta <<= 1;
	282	mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
	283	}
	284
	285	while (base)
	286	{
	287	GFC_REAL_4 *src;
	288	GFC_LOGICAL_4 *msrc;
	289	GFC_INTEGER_8 result;
	290	src = base;
	291	msrc = mbase;
	292	{
	293
	294	GFC_REAL_4 maxval;
	295	maxval = -GFC_REAL_4_HUGE;
	296	result = 1;
	297	if (len <= 0)
	298	*dest = 0;
	299	else
	300	{
	301	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	302	{
	303
	304	if (msrc && src > maxval)
	305	{
	306	maxval = *src;
	307	result = (GFC_INTEGER_8)n + 1;
	308	}
	309	}
	310	*dest = result;
	311	}
	312	}
	313	/* Advance to the next element. */
	314	count[0]++;
	315	base += sstride[0];
	316	mbase += mstride[0];
	317	dest += dstride[0];
	318	n = 0;
	319	while (count[n] == extent[n])
	320	{
	321	/* When we get to the end of a dimension, reset it and increment
	322	the next dimension. */
	323	count[n] = 0;
	324	/* We could precalculate these products, but this is a less
	325	frequently used path so proabably not worth it. */
	326	base -= sstride[n] * extent[n];
327	mbase -= mstride[n] * extent[n];
328	dest -= dstride[n] * extent[n];
329	n++;
330	if (n == rank)
331	{
332	/* Break out of the look. */
333	base = NULL;
334	break;
335	}
336	else
337	{
338	count[n]++;
339	base += sstride[n];
340	mbase += mstride[n];
341	dest += dstride[n];
342	}
343	}
344	}
345	}
346
644cb69f	347	#endif