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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2017-2018 Free Software Foundation, Inc.
   Contributed by Thomas Koenig

This file is part of the GNU Fortran 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 <string.h>
#include <assert.h>
#include <limits.h>


#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)

#define HAVE_BACK_ARG 1

static inline int
compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
{
  if (sizeof (GFC_INTEGER_1) == 1)
    return memcmp (a, b, n);
  else
    return memcmp_char4 (a, b, n);

}

extern void maxloc0_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len);
export_proto(maxloc0_8_s1);

void
maxloc0_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride;
  const GFC_INTEGER_1 *base;
  GFC_INTEGER_8 * restrict dest;
  index_type rank;
  index_type n;

#ifdef HAVE_BACK_ARG
  assert (back == 0);
#endif

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

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
    }
  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->base_addr;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
      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->base_addr;

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

  const GFC_INTEGER_1 *maxval;
   maxval = base;

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

  if (compare_fcn (base, maxval, len) > 0)
    {
      maxval = base;
      for (n = 0; n < rank; n++)
        dest[n * dstride] = count[n] + 1;
    }
	  /* Implementation end.  */
	  /* Advance to the next element.  */
	  base += sstride[0];
	}
      while (++count[0] != extent[0]);
      n = 0;
      do
	{
	  /* 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];
	    }
	}
      while (count[n] == extent[n]);
    }
  }
}


extern void mmaxloc0_8_s1 (gfc_array_i8 * const restrict, 
	gfc_array_s1 * const restrict, gfc_array_l1 * const restrict , GFC_LOGICAL_4 back,
	gfc_charlen_type len);
export_proto(mmaxloc0_8_s1);

void
mmaxloc0_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array,
	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
	gfc_charlen_type len)
{
  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_8 *dest;
  const GFC_INTEGER_1 *base;
  GFC_LOGICAL_1 *mbase;
  int rank;
  index_type n;
  int mask_kind;

#ifdef HAVE_BACK_ARG
  assert (back == 0);
#endif
  rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
      GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
    }
  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->base_addr;

  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->base_addr;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
      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->base_addr;

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

  const GFC_INTEGER_1 *maxval;

  maxval = NULL;

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

  if (*mbase && (maxval == NULL || compare_fcn (base, maxval, len) > 0))
    {
      maxval = base;
      for (n = 0; n < rank; n++)
        dest[n * dstride] = count[n] + 1;
    }
	  /* Implementation end.  */
	  /* Advance to the next element.  */
	  base += sstride[0];
	  mbase += mstride[0];
	}
      while (++count[0] != extent[0]);
      n = 0;
      do
	{
	  /* 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];
	    }
	}
      while (count[n] == extent[n]);
    }
  }
}


extern void smaxloc0_8_s1 (gfc_array_i8 * const restrict, 
	gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4 back,
	gfc_charlen_type len);
export_proto(smaxloc0_8_s1);

void
smaxloc0_8_s1 (gfc_array_i8 * const restrict retarray, 
	gfc_array_s1 * const restrict array,
	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back,
	gfc_charlen_type len)
{
  index_type rank;
  index_type dstride;
  index_type n;
  GFC_INTEGER_8 *dest;

  if (*mask)
    {
#ifdef HAVE_BACK_ARG    
      maxloc0_8_s1 (retarray, array, back, len);
#else
      maxloc0_8_s1 (retarray, array, len);
#endif
      return;
    }

  rank = GFC_DESCRIPTOR_RANK (array);

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

  if (retarray->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
      retarray->offset = 0;
      retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
    }
  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->base_addr;
  for (n = 0; n<rank; n++)
    dest[n * dstride] = 0 ;
}
#endif
Commit	Line	Data
ddc9995b	1	/* Implementation of the MAXLOC intrinsic
85ec4feb	2	Copyright (C) 2017-2018 Free Software Foundation, Inc.
ddc9995b TK	3	Contributed by Thomas Koenig
	4
	5	This file is part of the GNU Fortran 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 3 of the License, or (at your option) any later version.
	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
	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/>. */
	25
	26	#include "libgfortran.h"
	27	#include <stdlib.h>
	28	#include <string.h>
	29	#include <assert.h>
	30	#include <limits.h>
	31
	32
	33	#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
	34
64b1806b TK	35	#define HAVE_BACK_ARG 1
64b1806b TK	36
ddc9995b TK	37	static inline int
	38	compare_fcn (const GFC_INTEGER_1 a, const GFC_INTEGER_1 b, gfc_charlen_type n)
	39	{
	40	if (sizeof (GFC_INTEGER_1) == 1)
	41	return memcmp (a, b, n);
	42	else
	43	return memcmp_char4 (a, b, n);
	44
	45	}
	46
	47	extern void maxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
64b1806b	48	gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len);
ddc9995b TK	49	export_proto(maxloc0_8_s1);
	50
	51	void
	52	maxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
64b1806b	53	gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
ddc9995b TK	54	{
	55	index_type count[GFC_MAX_DIMENSIONS];
	56	index_type extent[GFC_MAX_DIMENSIONS];
	57	index_type sstride[GFC_MAX_DIMENSIONS];
	58	index_type dstride;
	59	const GFC_INTEGER_1 *base;
	60	GFC_INTEGER_8 * restrict dest;
	61	index_type rank;
	62	index_type n;
	63
64b1806b TK	64	#ifdef HAVE_BACK_ARG
	65	assert (back == 0);
	66	#endif
	67
ddc9995b TK	68	rank = GFC_DESCRIPTOR_RANK (array);
	69	if (rank <= 0)
	70	runtime_error ("Rank of array needs to be > 0");
	71
	72	if (retarray->base_addr == NULL)
	73	{
	74	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
fa3c4d47	75	GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
ddc9995b TK	76	retarray->offset = 0;
	77	retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
	78	}
	79	else
	80	{
	81	if (unlikely (compile_options.bounds_check))
	82	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	83	"MAXLOC");
	84	}
	85
	86	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
	87	dest = retarray->base_addr;
	88	for (n = 0; n < rank; n++)
	89	{
	90	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
	91	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	92	count[n] = 0;
	93	if (extent[n] <= 0)
	94	{
	95	/* Set the return value. */
	96	for (n = 0; n < rank; n++)
	97	dest[n * dstride] = 0;
	98	return;
	99	}
	100	}
	101
	102	base = array->base_addr;
	103
	104	/* Initialize the return value. */
	105	for (n = 0; n < rank; n++)
	106	dest[n * dstride] = 1;
	107	{
	108
	109	const GFC_INTEGER_1 *maxval;
	110	maxval = base;
	111
	112	while (base)
	113	{
	114	do
	115	{
	116	/* Implementation start. */
	117
	118	if (compare_fcn (base, maxval, len) > 0)
	119	{
	120	maxval = base;
	121	for (n = 0; n < rank; n++)
	122	dest[n * dstride] = count[n] + 1;
	123	}
	124	/* Implementation end. */
	125	/* Advance to the next element. */
	126	base += sstride[0];
	127	}
	128	while (++count[0] != extent[0]);
	129	n = 0;
	130	do
	131	{
	132	/* When we get to the end of a dimension, reset it and increment
	133	the next dimension. */
	134	count[n] = 0;
	135	/* We could precalculate these products, but this is a less
	136	frequently used path so probably not worth it. */
	137	base -= sstride[n] * extent[n];
	138	n++;
	139	if (n >= rank)
140	{
141	/* Break out of the loop. */
142	base = NULL;
143	break;
144	}
145	else
146	{
147	count[n]++;
148	base += sstride[n];
149	}
150	}
151	while (count[n] == extent[n]);
152	}
153	}
154	}
155
156
157	extern void mmaxloc0_8_s1 (gfc_array_i8 * const restrict,
64b1806b TK	158	gfc_array_s1 * const restrict, gfc_array_l1 * const restrict , GFC_LOGICAL_4 back,
64b1806b TK	159	gfc_charlen_type len);
ddc9995b TK	160	export_proto(mmaxloc0_8_s1);
	161
	162	void
	163	mmaxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
	164	gfc_array_s1 * const restrict array,
64b1806b TK	165	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
64b1806b TK	166	gfc_charlen_type len)
ddc9995b TK	167	{
	168	index_type count[GFC_MAX_DIMENSIONS];
	169	index_type extent[GFC_MAX_DIMENSIONS];
	170	index_type sstride[GFC_MAX_DIMENSIONS];
	171	index_type mstride[GFC_MAX_DIMENSIONS];
	172	index_type dstride;
	173	GFC_INTEGER_8 *dest;
	174	const GFC_INTEGER_1 *base;
	175	GFC_LOGICAL_1 *mbase;
	176	int rank;
	177	index_type n;
	178	int mask_kind;
	179
64b1806b TK	180	#ifdef HAVE_BACK_ARG
	181	assert (back == 0);
	182	#endif
ddc9995b TK	183	rank = GFC_DESCRIPTOR_RANK (array);
	184	if (rank <= 0)
	185	runtime_error ("Rank of array needs to be > 0");
	186
	187	if (retarray->base_addr == NULL)
	188	{
	189	GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
fa3c4d47	190	GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
ddc9995b TK	191	retarray->offset = 0;
	192	retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
	193	}
	194	else
	195	{
	196	if (unlikely (compile_options.bounds_check))
	197	{
	198
	199	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	200	"MAXLOC");
	201	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	202	"MASK argument", "MAXLOC");
	203	}
	204	}
	205
	206	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	207
	208	mbase = mask->base_addr;
	209
	210	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	211	#ifdef HAVE_GFC_LOGICAL_16
	212	\|\| mask_kind == 16
	213	#endif
	214	)
	215	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	216	else
	217	runtime_error ("Funny sized logical array");
	218
	219	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
	220	dest = retarray->base_addr;
	221	for (n = 0; n < rank; n++)
	222	{
	223	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len;
	224	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	225	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	226	count[n] = 0;
	227	if (extent[n] <= 0)
	228	{
	229	/* Set the return value. */
	230	for (n = 0; n < rank; n++)
	231	dest[n * dstride] = 0;
	232	return;
	233	}
	234	}
	235
	236	base = array->base_addr;
	237
	238	/* Initialize the return value. */
	239	for (n = 0; n < rank; n++)
	240	dest[n * dstride] = 0;
	241	{
	242
	243	const GFC_INTEGER_1 *maxval;
	244
	245	maxval = NULL;
	246
	247	while (base)
	248	{
	249	do
	250	{
	251	/* Implementation start. */
	252
	253	if (*mbase && (maxval == NULL \|\| compare_fcn (base, maxval, len) > 0))
	254	{
255	maxval = base;
256	for (n = 0; n < rank; n++)
257	dest[n * dstride] = count[n] + 1;
258	}
259	/* Implementation end. */
260	/* Advance to the next element. */
261	base += sstride[0];
262	mbase += mstride[0];
263	}
264	while (++count[0] != extent[0]);
265	n = 0;
266	do
267	{
268	/* When we get to the end of a dimension, reset it and increment
269	the next dimension. */
270	count[n] = 0;
271	/* We could precalculate these products, but this is a less
272	frequently used path so probably not worth it. */
273	base -= sstride[n] * extent[n];
274	mbase -= mstride[n] * extent[n];
275	n++;
276	if (n >= rank)
277	{
278	/* Break out of the loop. */
279	base = NULL;
280	break;
281	}
282	else
283	{
284	count[n]++;
285	base += sstride[n];
286	mbase += mstride[n];
287	}
288	}
289	while (count[n] == extent[n]);
290	}
291	}
292	}
293
294
295	extern void smaxloc0_8_s1 (gfc_array_i8 * const restrict,
64b1806b TK	296	gfc_array_s1 * const restrict, GFC_LOGICAL_4 *, GFC_LOGICAL_4 back,
64b1806b TK	297	gfc_charlen_type len);
ddc9995b TK	298	export_proto(smaxloc0_8_s1);
	299
	300	void
	301	smaxloc0_8_s1 (gfc_array_i8 * const restrict retarray,
	302	gfc_array_s1 * const restrict array,
64b1806b TK	303	GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back,
64b1806b TK	304	gfc_charlen_type len)
ddc9995b TK	305	{
	306	index_type rank;
	307	index_type dstride;
	308	index_type n;
	309	GFC_INTEGER_8 *dest;
	310
	311	if (*mask)
	312	{
64b1806b TK	313	#ifdef HAVE_BACK_ARG
	314	maxloc0_8_s1 (retarray, array, back, len);
	315	#else
ddc9995b	316	maxloc0_8_s1 (retarray, array, len);
64b1806b	317	#endif
ddc9995b TK	318	return;
	319	}
	320
	321	rank = GFC_DESCRIPTOR_RANK (array);
	322
	323	if (rank <= 0)
	324	runtime_error ("Rank of array needs to be > 0");
	325
	326	if (retarray->base_addr == NULL)
	327	{
	328	GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
fa3c4d47	329	GFC_DTYPE_COPY_SETRANK(retarray,retarray,1);
ddc9995b TK	330	retarray->offset = 0;
	331	retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_8));
	332	}
	333	else if (unlikely (compile_options.bounds_check))
	334	{
	335	bounds_iforeach_return ((array_t ) retarray, (array_t ) array,
	336	"MAXLOC");
	337	}
	338
	339	dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
	340	dest = retarray->base_addr;
	341	for (n = 0; n<rank; n++)
	342	dest[n * dstride] = 0 ;
	343	}
	344	#endif