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

/* Implementation of the MAXLOC intrinsic
   Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version.

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.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */

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


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


extern void maxloc0_16_r4 (gfc_array_i16 * const restrict retarray, 
	gfc_array_r4 * const restrict array);
export_proto(maxloc0_16_r4);

void
maxloc0_16_r4 (gfc_array_i16 * const restrict retarray, 
	gfc_array_r4 * 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_4 *base;
  GFC_INTEGER_16 * restrict 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)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
	                        "MAXLOC");
    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->data;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      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_4 maxval;

  maxval = -GFC_REAL_4_HUGE;

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

  if (*base > maxval || !dest[0])
    {
      maxval = *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 mmaxloc0_16_r4 (gfc_array_i16 * const restrict, 
	gfc_array_r4 * const restrict, gfc_array_l1 * const restrict);
export_proto(mmaxloc0_16_r4);

void
mmaxloc0_16_r4 (gfc_array_i16 * const restrict retarray, 
	gfc_array_r4 * 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_16 *dest;
  const GFC_REAL_4 *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)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
	{

	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
				  "MAXLOC");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
				  "MASK argument", "MAXLOC");
	}
    }

  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 = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->data;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      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_4 maxval;

  maxval = -GFC_REAL_4_HUGE;

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

  if (*mbase && (*base > maxval || !dest[0]))
    {
      maxval = *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 smaxloc0_16_r4 (gfc_array_i16 * const restrict, 
	gfc_array_r4 * const restrict, GFC_LOGICAL_4 *);
export_proto(smaxloc0_16_r4);

void
smaxloc0_16_r4 (gfc_array_i16 * const restrict retarray, 
	gfc_array_r4 * const restrict array,
	GFC_LOGICAL_4 * mask)
{
  index_type rank;
  index_type dstride;
  index_type n;
  GFC_INTEGER_16 *dest;

  if (*mask)
    {
      maxloc0_16_r4 (retarray, array);
      return;
    }

  rank = GFC_DESCRIPTOR_RANK (array);

  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->data == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
    }
  else if (unlikely (compile_options.bounds_check))
    {
       bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
			       "MAXLOC");
    }

  dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->data;
  for (n = 0; n<rank; n++)
    dest[n * dstride] = 0 ;
}
#endif
Commit	Line	Data
644cb69f	1	/* Implementation of the MAXLOC intrinsic
748086b7	2	Copyright 2002, 2007, 2009 Free Software Foundation, Inc.
644cb69f FXC	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
748086b7	10	version 3 of the License, or (at your option) any later version.
644cb69f FXC	11
	12	Libgfortran is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
	16
748086b7 JJ	17	Under Section 7 of GPL version 3, you are granted additional
	18	permissions described in the GCC Runtime Library Exception, version
	19	3.1, as published by the Free Software Foundation.
	20
	21	You should have received a copy of the GNU General Public License and
	22	a copy of the GCC Runtime Library Exception along with this program;
	23	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	24	<http://www.gnu.org/licenses/>. */
644cb69f	25
36ae8a61	26	#include "libgfortran.h"
644cb69f FXC	27	#include <stdlib.h>
644cb69f FXC	28	#include <assert.h>
644cb69f	29	#include <limits.h>
644cb69f FXC	30
	31
	32	#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16)
	33
	34
64acfd99 JB	35	extern void maxloc0_16_r4 (gfc_array_i16 * const restrict retarray,
64acfd99 JB	36	gfc_array_r4 * const restrict array);
644cb69f FXC	37	export_proto(maxloc0_16_r4);
	38
	39	void
64acfd99 JB	40	maxloc0_16_r4 (gfc_array_i16 * const restrict retarray,
64acfd99 JB	41	gfc_array_r4 * const restrict array)
644cb69f FXC	42	{
	43	index_type count[GFC_MAX_DIMENSIONS];
	44	index_type extent[GFC_MAX_DIMENSIONS];
	45	index_type sstride[GFC_MAX_DIMENSIONS];
	46	index_type dstride;
64acfd99	47	const GFC_REAL_4 *base;
5863aacf	48	GFC_INTEGER_16 * restrict dest;
644cb69f FXC	49	index_type rank;
	50	index_type n;
	51
	52	rank = GFC_DESCRIPTOR_RANK (array);
	53	if (rank <= 0)
	54	runtime_error ("Rank of array needs to be > 0");
	55
	56	if (retarray->data == NULL)
	57	{
dfb55fdc	58	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
644cb69f FXC	59	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	60	retarray->offset = 0;
	61	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
	62	}
	63	else
	64	{
9731c4a3	65	if (unlikely (compile_options.bounds_check))
16bff921 TK	66	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
16bff921 TK	67	"MAXLOC");
644cb69f FXC	68	}
644cb69f FXC	69
dfb55fdc	70	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
644cb69f FXC	71	dest = retarray->data;
	72	for (n = 0; n < rank; n++)
	73	{
dfb55fdc TK	74	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
dfb55fdc TK	75	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
644cb69f FXC	76	count[n] = 0;
	77	if (extent[n] <= 0)
	78	{
	79	/* Set the return value. */
	80	for (n = 0; n < rank; n++)
	81	dest[n * dstride] = 0;
	82	return;
	83	}
	84	}
	85
	86	base = array->data;
	87
	88	/* Initialize the return value. */
	89	for (n = 0; n < rank; n++)
a4b9e93e	90	dest[n * dstride] = 0;
644cb69f FXC	91	{
	92
	93	GFC_REAL_4 maxval;
	94
	95	maxval = -GFC_REAL_4_HUGE;
	96
	97	while (base)
	98	{
	99	{
	100	/* Implementation start. */
	101
a4b9e93e	102	if (*base > maxval \|\| !dest[0])
644cb69f FXC	103	{
	104	maxval = *base;
	105	for (n = 0; n < rank; n++)
	106	dest[n * dstride] = count[n] + 1;
	107	}
	108	/* Implementation end. */
	109	}
	110	/* Advance to the next element. */
	111	count[0]++;
	112	base += sstride[0];
	113	n = 0;
	114	while (count[n] == extent[n])
	115	{
	116	/* When we get to the end of a dimension, reset it and increment
	117	the next dimension. */
	118	count[n] = 0;
	119	/* We could precalculate these products, but this is a less
5d7adf7a	120	frequently used path so probably not worth it. */
644cb69f FXC	121	base -= sstride[n] * extent[n];
	122	n++;
	123	if (n == rank)
	124	{
	125	/* Break out of the loop. */
	126	base = NULL;
	127	break;
	128	}
	129	else
	130	{
	131	count[n]++;
	132	base += sstride[n];
	133	}
	134	}
	135	}
	136	}
	137	}
	138
	139
64acfd99	140	extern void mmaxloc0_16_r4 (gfc_array_i16 * const restrict,
28dc6b33	141	gfc_array_r4 * const restrict, gfc_array_l1 * const restrict);
644cb69f FXC	142	export_proto(mmaxloc0_16_r4);
	143
	144	void
64acfd99 JB	145	mmaxloc0_16_r4 (gfc_array_i16 * const restrict retarray,
64acfd99 JB	146	gfc_array_r4 * const restrict array,
28dc6b33	147	gfc_array_l1 * const restrict mask)
644cb69f FXC	148	{
	149	index_type count[GFC_MAX_DIMENSIONS];
	150	index_type extent[GFC_MAX_DIMENSIONS];
	151	index_type sstride[GFC_MAX_DIMENSIONS];
	152	index_type mstride[GFC_MAX_DIMENSIONS];
	153	index_type dstride;
	154	GFC_INTEGER_16 *dest;
64acfd99	155	const GFC_REAL_4 *base;
28dc6b33	156	GFC_LOGICAL_1 *mbase;
644cb69f FXC	157	int rank;
644cb69f FXC	158	index_type n;
28dc6b33	159	int mask_kind;
644cb69f FXC	160
	161	rank = GFC_DESCRIPTOR_RANK (array);
	162	if (rank <= 0)
	163	runtime_error ("Rank of array needs to be > 0");
	164
	165	if (retarray->data == NULL)
	166	{
dfb55fdc	167	GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
644cb69f FXC	168	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	169	retarray->offset = 0;
	170	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
	171	}
	172	else
	173	{
9731c4a3	174	if (unlikely (compile_options.bounds_check))
fd6590f8	175	{
16bff921 TK	176
	177	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	178	"MAXLOC");
	179	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	180	"MASK argument", "MAXLOC");
fd6590f8	181	}
644cb69f FXC	182	}
644cb69f FXC	183
28dc6b33 TK	184	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	185
	186	mbase = mask->data;
	187
	188	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	189	#ifdef HAVE_GFC_LOGICAL_16
	190	\|\| mask_kind == 16
	191	#endif
	192	)
	193	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	194	else
	195	runtime_error ("Funny sized logical array");
	196
dfb55fdc	197	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
644cb69f FXC	198	dest = retarray->data;
	199	for (n = 0; n < rank; n++)
	200	{
dfb55fdc TK	201	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	202	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	203	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
644cb69f FXC	204	count[n] = 0;
	205	if (extent[n] <= 0)
	206	{
	207	/* Set the return value. */
	208	for (n = 0; n < rank; n++)
	209	dest[n * dstride] = 0;
	210	return;
	211	}
	212	}
	213
	214	base = array->data;
644cb69f FXC	215
	216	/* Initialize the return value. */
	217	for (n = 0; n < rank; n++)
a4b9e93e	218	dest[n * dstride] = 0;
644cb69f FXC	219	{
	220
	221	GFC_REAL_4 maxval;
	222
	223	maxval = -GFC_REAL_4_HUGE;
	224
	225	while (base)
	226	{
	227	{
	228	/* Implementation start. */
	229
a4b9e93e	230	if (mbase && (base > maxval \|\| !dest[0]))
644cb69f FXC	231	{
	232	maxval = *base;
	233	for (n = 0; n < rank; n++)
	234	dest[n * dstride] = count[n] + 1;
	235	}
	236	/* Implementation end. */
	237	}
	238	/* Advance to the next element. */
	239	count[0]++;
	240	base += sstride[0];
	241	mbase += mstride[0];
	242	n = 0;
	243	while (count[n] == extent[n])
	244	{
	245	/* When we get to the end of a dimension, reset it and increment
	246	the next dimension. */
	247	count[n] = 0;
	248	/* We could precalculate these products, but this is a less
5d7adf7a	249	frequently used path so probably not worth it. */
644cb69f FXC	250	base -= sstride[n] * extent[n];
	251	mbase -= mstride[n] * extent[n];
	252	n++;
	253	if (n == rank)
	254	{
	255	/* Break out of the loop. */
	256	base = NULL;
	257	break;
	258	}
	259	else
	260	{
	261	count[n]++;
	262	base += sstride[n];
	263	mbase += mstride[n];
	264	}
	265	}
	266	}
	267	}
	268	}
	269
97a62038 TK	270
	271	extern void smaxloc0_16_r4 (gfc_array_i16 * const restrict,
	272	gfc_array_r4 * const restrict, GFC_LOGICAL_4 *);
	273	export_proto(smaxloc0_16_r4);
	274
	275	void
	276	smaxloc0_16_r4 (gfc_array_i16 * const restrict retarray,
	277	gfc_array_r4 * const restrict array,
	278	GFC_LOGICAL_4 * mask)
	279	{
	280	index_type rank;
	281	index_type dstride;
	282	index_type n;
	283	GFC_INTEGER_16 *dest;
	284
	285	if (*mask)
	286	{
	287	maxloc0_16_r4 (retarray, array);
	288	return;
	289	}
	290
	291	rank = GFC_DESCRIPTOR_RANK (array);
	292
	293	if (rank <= 0)
	294	runtime_error ("Rank of array needs to be > 0");
	295
	296	if (retarray->data == NULL)
	297	{
dfb55fdc	298	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
97a62038 TK	299	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	300	retarray->offset = 0;
	301	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
	302	}
16bff921	303	else if (unlikely (compile_options.bounds_check))
97a62038	304	{
16bff921 TK	305	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
16bff921 TK	306	"MAXLOC");
97a62038 TK	307	}
97a62038 TK	308
dfb55fdc	309	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
97a62038 TK	310	dest = retarray->data;
	311	for (n = 0; n<rank; n++)
	312	dest[n * dstride] = 0 ;
	313	}
644cb69f	314	#endif