[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., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

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


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