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

/* Implementation of the MAXLOC intrinsic
   Copyright (C) 2017-2024 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_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8)

#define HAVE_BACK_ARG 1

static inline int
compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
{
  if (sizeof (GFC_UINTEGER_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_UINTEGER_1 *base;
  GFC_INTEGER_8 * 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->base_addr == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
      retarray->dtype.rank = 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_UINTEGER_1 *maxval;
   maxval = NULL;

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

    if (maxval == NULL || (back ? compare_fcn (base, maxval, len) >= 0 :
     		   	   	   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_UINTEGER_1 *base;
  GFC_LOGICAL_1 *mbase;
  int rank;
  index_type n;
  int mask_kind;

  if (mask == NULL)
    {
#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);
      retarray->dtype.rank = 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_UINTEGER_1 *maxval;

  maxval = NULL;

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

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