[thirdparty/gcc.git] / libgfortran / generated / maxloc1_4_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., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

#include "config.h"
#include <stdlib.h>
#include <assert.h>
#include <float.h>
#include <limits.h>
#include "libgfortran.h"


extern void maxloc1_4_r4 (gfc_array_i4 *, gfc_array_r4 *, index_type *);
export_proto(maxloc1_4_r4);

void
maxloc1_4_r4 (gfc_array_i4 *retarray, gfc_array_r4 *array, index_type *pdim)
{
  index_type count[GFC_MAX_DIMENSIONS - 1];
  index_type extent[GFC_MAX_DIMENSIONS - 1];
  index_type sstride[GFC_MAX_DIMENSIONS - 1];
  index_type dstride[GFC_MAX_DIMENSIONS - 1];
  GFC_REAL_4 *base;
  GFC_INTEGER_4 *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;
  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_4)
		 		 * retarray->dim[rank-1].stride
				 * extent[rank-1]);
      retarray->base = 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_4 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_4)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_4_r4 (gfc_array_i4 *, gfc_array_r4 *, index_type *,
					       gfc_array_l4 *);
export_proto(mmaxloc1_4_r4);

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