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

/* Implementation of the MINVAL 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 "libgfortran.h"


#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4)


extern void minval_r4 (gfc_array_r4 *, gfc_array_r4 *, index_type *);
export_proto(minval_r4);

void
minval_r4 (gfc_array_r4 *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_REAL_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;

  /* 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_REAL_4)
		 		 * 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_REAL_4 result;
      src = base;
      {

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

  if (*src < result)
    result = *src;
          }
	    *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 mminval_r4 (gfc_array_r4 *, gfc_array_r4 *, index_type *,
					       gfc_array_l4 *);
export_proto(mminval_r4);

void
mminval_r4 (gfc_array_r4 * 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_REAL_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;

  /* 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_REAL_4)
		 		 * 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_REAL_4 result;
      src = base;
      msrc = mbase;
      {

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

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