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

/* Implementation of the MINLOC intrinsic
   Copyright 2002, 2007 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 "libgfortran.h"
#include <stdlib.h>
#include <assert.h>
#include <limits.h>


#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4)


extern void minloc0_4_r8 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r8 * const restrict array);
export_proto(minloc0_4_r8);

void
minloc0_4_r8 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r8 * 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_8 *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_8 minval;

  minval = GFC_REAL_8_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_r8 (gfc_array_i4 * const restrict, 
	gfc_array_r8 * const restrict, gfc_array_l1 * const restrict);
export_proto(mminloc0_4_r8);

void
mminloc0_4_r8 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r8 * const restrict array,
	gfc_array_l1 * 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_8 *base;
  GFC_LOGICAL_1 *mbase;
  int rank;
  index_type n;
  int mask_kind;

  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");
    }

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  mbase = mask->data;

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
  else
    runtime_error ("Funny sized logical array");

  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 * mask_kind;
      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_8 minval;

  minval = GFC_REAL_8_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_r8 (gfc_array_i4 * const restrict, 
	gfc_array_r8 * const restrict, GFC_LOGICAL_4 *);
export_proto(sminloc0_4_r8);

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

  if (*mask)
    {
      minloc0_4_r8 (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
6de9cd9a	1	/* Implementation of the MINLOC intrinsic
36ae8a61	2	Copyright 2002, 2007 Free Software Foundation, Inc.
6de9cd9a DN	3	Contributed by Paul Brook <paul@nowt.org>
6de9cd9a DN	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	30
36ae8a61	31	#include "libgfortran.h"
6de9cd9a DN	32	#include <stdlib.h>
6de9cd9a DN	33	#include <assert.h>
6de9cd9a	34	#include <limits.h>
6de9cd9a DN	35
6de9cd9a DN	36
644cb69f FXC	37	#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4)
644cb69f FXC	38
7d7b8bfe	39
64acfd99 JB	40	extern void minloc0_4_r8 (gfc_array_i4 * const restrict retarray,
64acfd99 JB	41	gfc_array_r8 * const restrict array);
7f68c75f	42	export_proto(minloc0_4_r8);
7d7b8bfe	43
6de9cd9a	44	void
64acfd99 JB	45	minloc0_4_r8 (gfc_array_i4 * const restrict retarray,
64acfd99 JB	46	gfc_array_r8 * const restrict array)
6de9cd9a DN	47	{
	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;
64acfd99	52	const GFC_REAL_8 *base;
6de9cd9a DN	53	GFC_INTEGER_4 *dest;
	54	index_type rank;
	55	index_type n;
	56
	57	rank = GFC_DESCRIPTOR_RANK (array);
50dd63a9 TK	58	if (rank <= 0)
	59	runtime_error ("Rank of array needs to be > 0");
	60
	61	if (retarray->data == NULL)
	62	{
	63	retarray->dim[0].lbound = 0;
	64	retarray->dim[0].ubound = rank-1;
	65	retarray->dim[0].stride = 1;
	66	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
efd4dc1a	67	retarray->offset = 0;
50dd63a9 TK	68	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
	69	}
	70	else
	71	{
	72	if (GFC_DESCRIPTOR_RANK (retarray) != 1)
	73	runtime_error ("rank of return array does not equal 1");
	74
	75	if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
	76	runtime_error ("dimension of return array incorrect");
50dd63a9	77	}
e33e218b	78
6de9cd9a DN	79	dstride = retarray->dim[0].stride;
	80	dest = retarray->data;
	81	for (n = 0; n < rank; n++)
	82	{
	83	sstride[n] = array->dim[n].stride;
	84	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
	85	count[n] = 0;
	86	if (extent[n] <= 0)
	87	{
	88	/* Set the return value. */
	89	for (n = 0; n < rank; n++)
	90	dest[n * dstride] = 0;
	91	return;
	92	}
	93	}
	94
	95	base = array->data;
	96
	97	/* Initialize the return value. */
	98	for (n = 0; n < rank; n++)
a4b9e93e	99	dest[n * dstride] = 0;
6de9cd9a DN	100	{
	101
	102	GFC_REAL_8 minval;
	103
	104	minval = GFC_REAL_8_HUGE;
	105
	106	while (base)
	107	{
	108	{
	109	/* Implementation start. */
	110
a4b9e93e	111	if (*base < minval \|\| !dest[0])
6de9cd9a DN	112	{
	113	minval = *base;
	114	for (n = 0; n < rank; n++)
	115	dest[n * dstride] = count[n] + 1;
	116	}
	117	/* Implementation end. */
	118	}
	119	/* Advance to the next element. */
	120	count[0]++;
	121	base += sstride[0];
	122	n = 0;
	123	while (count[n] == extent[n])
	124	{
	125	/* When we get to the end of a dimension, reset it and increment
	126	the next dimension. */
	127	count[n] = 0;
	128	/* We could precalculate these products, but this is a less
5d7adf7a	129	frequently used path so probably not worth it. */
6de9cd9a DN	130	base -= sstride[n] * extent[n];
	131	n++;
	132	if (n == rank)
	133	{
	134	/* Break out of the loop. */
	135	base = NULL;
	136	break;
	137	}
	138	else
	139	{
	140	count[n]++;
	141	base += sstride[n];
	142	}
	143	}
	144	}
	145	}
	146	}
	147
7d7b8bfe	148
64acfd99	149	extern void mminloc0_4_r8 (gfc_array_i4 * const restrict,
28dc6b33	150	gfc_array_r8 * const restrict, gfc_array_l1 * const restrict);
7f68c75f	151	export_proto(mminloc0_4_r8);
7d7b8bfe	152
6de9cd9a	153	void
64acfd99 JB	154	mminloc0_4_r8 (gfc_array_i4 * const restrict retarray,
64acfd99 JB	155	gfc_array_r8 * const restrict array,
28dc6b33	156	gfc_array_l1 * const restrict mask)
6de9cd9a DN	157	{
	158	index_type count[GFC_MAX_DIMENSIONS];
	159	index_type extent[GFC_MAX_DIMENSIONS];
	160	index_type sstride[GFC_MAX_DIMENSIONS];
	161	index_type mstride[GFC_MAX_DIMENSIONS];
	162	index_type dstride;
	163	GFC_INTEGER_4 *dest;
64acfd99	164	const GFC_REAL_8 *base;
28dc6b33	165	GFC_LOGICAL_1 *mbase;
6de9cd9a DN	166	int rank;
6de9cd9a DN	167	index_type n;
28dc6b33	168	int mask_kind;
6de9cd9a DN	169
6de9cd9a DN	170	rank = GFC_DESCRIPTOR_RANK (array);
50dd63a9 TK	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;
efd4dc1a	180	retarray->offset = 0;
50dd63a9 TK	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");
50dd63a9	190	}
6de9cd9a	191
28dc6b33 TK	192	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	193
	194	mbase = mask->data;
	195
	196	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	197	#ifdef HAVE_GFC_LOGICAL_16
	198	\|\| mask_kind == 16
	199	#endif
	200	)
	201	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	202	else
	203	runtime_error ("Funny sized logical array");
	204
6de9cd9a DN	205	dstride = retarray->dim[0].stride;
	206	dest = retarray->data;
	207	for (n = 0; n < rank; n++)
	208	{
	209	sstride[n] = array->dim[n].stride;
28dc6b33	210	mstride[n] = mask->dim[n].stride * mask_kind;
6de9cd9a DN	211	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
	212	count[n] = 0;
	213	if (extent[n] <= 0)
	214	{
	215	/* Set the return value. */
	216	for (n = 0; n < rank; n++)
	217	dest[n * dstride] = 0;
	218	return;
	219	}
	220	}
	221
	222	base = array->data;
6de9cd9a DN	223
	224	/* Initialize the return value. */
	225	for (n = 0; n < rank; n++)
a4b9e93e	226	dest[n * dstride] = 0;
6de9cd9a DN	227	{
	228
	229	GFC_REAL_8 minval;
	230
	231	minval = GFC_REAL_8_HUGE;
	232
	233	while (base)
	234	{
	235	{
	236	/* Implementation start. */
	237
a4b9e93e	238	if (mbase && (base < minval \|\| !dest[0]))
6de9cd9a DN	239	{
	240	minval = *base;
	241	for (n = 0; n < rank; n++)
	242	dest[n * dstride] = count[n] + 1;
	243	}
	244	/* Implementation end. */
	245	}
	246	/* Advance to the next element. */
	247	count[0]++;
	248	base += sstride[0];
	249	mbase += mstride[0];
	250	n = 0;
	251	while (count[n] == extent[n])
	252	{
	253	/* When we get to the end of a dimension, reset it and increment
	254	the next dimension. */
	255	count[n] = 0;
	256	/* We could precalculate these products, but this is a less
5d7adf7a	257	frequently used path so probably not worth it. */
6de9cd9a DN	258	base -= sstride[n] * extent[n];
	259	mbase -= mstride[n] * extent[n];
	260	n++;
	261	if (n == rank)
	262	{
	263	/* Break out of the loop. */
	264	base = NULL;
	265	break;
	266	}
	267	else
	268	{
	269	count[n]++;
	270	base += sstride[n];
	271	mbase += mstride[n];
	272	}
	273	}
	274	}
	275	}
	276	}
644cb69f	277
97a62038 TK	278
	279	extern void sminloc0_4_r8 (gfc_array_i4 * const restrict,
	280	gfc_array_r8 * const restrict, GFC_LOGICAL_4 *);
	281	export_proto(sminloc0_4_r8);
	282
	283	void
	284	sminloc0_4_r8 (gfc_array_i4 * const restrict retarray,
	285	gfc_array_r8 * const restrict array,
	286	GFC_LOGICAL_4 * mask)
	287	{
	288	index_type rank;
	289	index_type dstride;
	290	index_type n;
	291	GFC_INTEGER_4 *dest;
	292
	293	if (*mask)
	294	{
	295	minloc0_4_r8 (retarray, array);
	296	return;
	297	}
	298
	299	rank = GFC_DESCRIPTOR_RANK (array);
	300
	301	if (rank <= 0)
	302	runtime_error ("Rank of array needs to be > 0");
	303
	304	if (retarray->data == NULL)
	305	{
	306	retarray->dim[0].lbound = 0;
	307	retarray->dim[0].ubound = rank-1;
	308	retarray->dim[0].stride = 1;
	309	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	310	retarray->offset = 0;
	311	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
	312	}
	313	else
	314	{
	315	if (GFC_DESCRIPTOR_RANK (retarray) != 1)
	316	runtime_error ("rank of return array does not equal 1");
	317
	318	if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
	319	runtime_error ("dimension of return array incorrect");
97a62038 TK	320	}
	321
	322	dstride = retarray->dim[0].stride;
	323	dest = retarray->data;
	324	for (n = 0; n<rank; n++)
	325	dest[n * dstride] = 0 ;
	326	}
644cb69f	327	#endif