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

/* Implementation of the MINLOC 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_REAL_16) && defined (HAVE_GFC_INTEGER_4)


extern void minloc0_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * const restrict array);
export_proto(minloc0_4_r16);

void
minloc0_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * 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_REAL_16 *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_REAL_16 minval;

  minval = GFC_REAL_16_HUGE;

  while (base)
    {
      {
        /* Implementation start.  */

  if (*base < minval || !dest[0])
    {
      minval = *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 mminloc0_4_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, gfc_array_l4 * const restrict);
export_proto(mminloc0_4_r16);

void
mminloc0_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * const restrict array,
	gfc_array_l4 * 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_REAL_16 *base;
  GFC_LOGICAL_4 *mbase;
  int 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;
      mstride[n] = mask->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;
  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;
      mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
    }


  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;
  {

  GFC_REAL_16 minval;

  minval = GFC_REAL_16_HUGE;

  while (base)
    {
      {
        /* Implementation start.  */

  if (*mbase && (*base < minval || !dest[0]))
    {
      minval = *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 sminloc0_4_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, GFC_LOGICAL_4 *);
export_proto(sminloc0_4_r16);

void
sminloc0_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * const restrict array,
	GFC_LOGICAL_4 * mask)
{
  index_type rank;
  index_type dstride;
  index_type n;
  GFC_INTEGER_4 *dest;

  if (*mask)
    {
      minloc0_4_r16 (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
644cb69f FXC	1	/* Implementation of the MINLOC 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>
644cb69f FXC	34	#include <limits.h>
	35	#include "libgfortran.h"
	36
	37
	38	#if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_4)
	39
	40
64acfd99 JB	41	extern void minloc0_4_r16 (gfc_array_i4 * const restrict retarray,
64acfd99 JB	42	gfc_array_r16 * const restrict array);
644cb69f FXC	43	export_proto(minloc0_4_r16);
	44
	45	void
64acfd99 JB	46	minloc0_4_r16 (gfc_array_i4 * const restrict retarray,
64acfd99 JB	47	gfc_array_r16 * const restrict array)
644cb69f FXC	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;
64acfd99	53	const GFC_REAL_16 *base;
644cb69f FXC	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");
644cb69f FXC	78	}
644cb69f FXC	79
644cb69f FXC	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++)
a4b9e93e	100	dest[n * dstride] = 0;
644cb69f FXC	101	{
	102
	103	GFC_REAL_16 minval;
	104
	105	minval = GFC_REAL_16_HUGE;
	106
	107	while (base)
	108	{
	109	{
	110	/* Implementation start. */
	111
a4b9e93e	112	if (*base < minval \|\| !dest[0])
644cb69f FXC	113	{
	114	minval = *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
5d7adf7a	130	frequently used path so probably not worth it. */
644cb69f FXC	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
64acfd99 JB	150	extern void mminloc0_4_r16 (gfc_array_i4 * const restrict,
64acfd99 JB	151	gfc_array_r16 * const restrict, gfc_array_l4 * const restrict);
644cb69f FXC	152	export_proto(mminloc0_4_r16);
	153
	154	void
64acfd99 JB	155	mminloc0_4_r16 (gfc_array_i4 * const restrict retarray,
	156	gfc_array_r16 * const restrict array,
	157	gfc_array_l4 * const restrict mask)
644cb69f FXC	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;
64acfd99	165	const GFC_REAL_16 *base;
644cb69f FXC	166	GFC_LOGICAL_4 *mbase;
	167	int rank;
	168	index_type n;
	169
	170	rank = GFC_DESCRIPTOR_RANK (array);
	171	if (rank <= 0)
	172	runtime_error ("Rank of array needs to be > 0");
	173
	174	if (retarray->data == NULL)
	175	{
	176	retarray->dim[0].lbound = 0;
	177	retarray->dim[0].ubound = rank-1;
	178	retarray->dim[0].stride = 1;
	179	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	180	retarray->offset = 0;
	181	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
	182	}
	183	else
	184	{
	185	if (GFC_DESCRIPTOR_RANK (retarray) != 1)
	186	runtime_error ("rank of return array does not equal 1");
	187
	188	if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
	189	runtime_error ("dimension of return array incorrect");
644cb69f FXC	190	}
644cb69f FXC	191
644cb69f FXC	192	dstride = retarray->dim[0].stride;
	193	dest = retarray->data;
	194	for (n = 0; n < rank; n++)
	195	{
	196	sstride[n] = array->dim[n].stride;
	197	mstride[n] = mask->dim[n].stride;
	198	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
	199	count[n] = 0;
	200	if (extent[n] <= 0)
	201	{
	202	/* Set the return value. */
	203	for (n = 0; n < rank; n++)
	204	dest[n * dstride] = 0;
	205	return;
	206	}
	207	}
	208
	209	base = array->data;
	210	mbase = mask->data;
	211
	212	if (GFC_DESCRIPTOR_SIZE (mask) != 4)
	213	{
	214	/* This allows the same loop to be used for all logical types. */
	215	assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
	216	for (n = 0; n < rank; n++)
	217	mstride[n] <<= 1;
	218	mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
	219	}
	220
	221
	222	/* Initialize the return value. */
	223	for (n = 0; n < rank; n++)
a4b9e93e	224	dest[n * dstride] = 0;
644cb69f FXC	225	{
	226
	227	GFC_REAL_16 minval;
	228
	229	minval = GFC_REAL_16_HUGE;
	230
	231	while (base)
	232	{
	233	{
	234	/* Implementation start. */
	235
a4b9e93e	236	if (mbase && (base < minval \|\| !dest[0]))
644cb69f FXC	237	{
	238	minval = *base;
	239	for (n = 0; n < rank; n++)
	240	dest[n * dstride] = count[n] + 1;
	241	}
	242	/* Implementation end. */
	243	}
	244	/* Advance to the next element. */
	245	count[0]++;
	246	base += sstride[0];
	247	mbase += mstride[0];
	248	n = 0;
	249	while (count[n] == extent[n])
	250	{
	251	/* When we get to the end of a dimension, reset it and increment
	252	the next dimension. */
	253	count[n] = 0;
	254	/* We could precalculate these products, but this is a less
5d7adf7a	255	frequently used path so probably not worth it. */
644cb69f FXC	256	base -= sstride[n] * extent[n];
	257	mbase -= mstride[n] * extent[n];
	258	n++;
	259	if (n == rank)
	260	{
	261	/* Break out of the loop. */
	262	base = NULL;
	263	break;
	264	}
	265	else
	266	{
	267	count[n]++;
	268	base += sstride[n];
	269	mbase += mstride[n];
	270	}
	271	}
	272	}
	273	}
	274	}
	275
97a62038 TK	276
	277	extern void sminloc0_4_r16 (gfc_array_i4 * const restrict,
	278	gfc_array_r16 * const restrict, GFC_LOGICAL_4 *);
	279	export_proto(sminloc0_4_r16);
	280
	281	void
	282	sminloc0_4_r16 (gfc_array_i4 * const restrict retarray,
	283	gfc_array_r16 * const restrict array,
	284	GFC_LOGICAL_4 * mask)
	285	{
	286	index_type rank;
	287	index_type dstride;
	288	index_type n;
	289	GFC_INTEGER_4 *dest;
	290
	291	if (*mask)
	292	{
	293	minloc0_4_r16 (retarray, array);
	294	return;
	295	}
	296
	297	rank = GFC_DESCRIPTOR_RANK (array);
	298
	299	if (rank <= 0)
	300	runtime_error ("Rank of array needs to be > 0");
	301
	302	if (retarray->data == NULL)
	303	{
	304	retarray->dim[0].lbound = 0;
	305	retarray->dim[0].ubound = rank-1;
	306	retarray->dim[0].stride = 1;
	307	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	308	retarray->offset = 0;
	309	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
	310	}
	311	else
	312	{
	313	if (GFC_DESCRIPTOR_RANK (retarray) != 1)
	314	runtime_error ("rank of return array does not equal 1");
	315
	316	if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
	317	runtime_error ("dimension of return array incorrect");
97a62038 TK	318	}
	319
	320	dstride = retarray->dim[0].stride;
	321	dest = retarray->data;
	322	for (n = 0; n<rank; n++)
	323	dest[n * dstride] = 0 ;
	324	}
644cb69f	325	#endif