[gcc.git] / libgfortran / generated / minloc1_4_s4.c

/* Implementation of the MINLOC 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"


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

#define HAVE_BACK_ARG 1

#include <string.h>
#include <assert.h>

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

extern void minloc1_4_s4 (gfc_array_i4 * const restrict, 
	gfc_array_s4 * const restrict, const index_type * const restrict , GFC_LOGICAL_4 back,
	gfc_charlen_type);
export_proto(minloc1_4_s4);

void
minloc1_4_s4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_s4 * const restrict array, 
	const index_type * const restrict pdim, GFC_LOGICAL_4 back,
	gfc_charlen_type string_len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_INTEGER_4 * restrict base;
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

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

  /* Make dim zero based to avoid confusion.  */
  rank = GFC_DESCRIPTOR_RANK (array) - 1;
  dim = (*pdim) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len < 0)
    len = 0;
  delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      retarray->offset = 0;
      GFC_DTYPE_COPY_SETRANK(retarray,array,rank);

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;

	}
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " MINLOC intrinsic: is %ld, should be %ld",
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
		       (long int) rank);

      if (unlikely (compile_options.bounds_check))
	bounds_ifunction_return ((array_t *) retarray, extent,
				 "return value", "MINLOC");
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
	return;
    }

  base = array->base_addr;
  dest = retarray->base_addr;

  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_INTEGER_4 * restrict src;
      GFC_INTEGER_4 result;
      src = base;
      {

	const GFC_INTEGER_4 *minval;
	minval = base;
	result = 1;
	if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

		if (compare_fcn (src, minval, string_len) < 0)
		  {
		    minval = src;
		    result = (GFC_INTEGER_4)n + 1;
		  }
	      }
	    
	    *dest = result;
	  }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      dest += dstride[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];
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      /* Break out of the loop.  */
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void mminloc1_4_s4 (gfc_array_i4 * const restrict, 
	gfc_array_s4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict, GFC_LOGICAL_4 back, gfc_charlen_type);
export_proto(mminloc1_4_s4);

void
mminloc1_4_s4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_s4 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
	gfc_charlen_type string_len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_4 * restrict dest;
  const GFC_INTEGER_4 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  index_type rank;
  index_type dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

#ifdef HAVE_BACK_ARG
  assert (back == 0);
#endif
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;


  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len <= 0)
    return;

  mbase = mask->base_addr;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

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

  delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;

    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      retarray->offset = 0;
      GFC_DTYPE_COPY_SETRANK(retarray,array,rank);

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));

    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in MINLOC intrinsic");

      if (unlikely (compile_options.bounds_check))
	{
	  bounds_ifunction_return ((array_t *) retarray, extent,
				   "return value", "MINLOC");
	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
	  			"MASK argument", "MINLOC");
	}
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
      if (extent[n] <= 0)
	return;
    }

  dest = retarray->base_addr;
  base = array->base_addr;

  while (base)
    {
      const GFC_INTEGER_4 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_4 result;
      src = base;
      msrc = mbase;
      {

	const GFC_INTEGER_4 *minval;
	minval = base;
	result = 0;
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

		if (*msrc)
		      {
			minval = src;
			result = (GFC_INTEGER_4)n + 1;
			break;
		      }
            }
	    for (; n < len; n++, src += delta, msrc += mdelta)
	      {
		if (*msrc && compare_fcn (src, minval, string_len) < 0)
		  {
		    minval = src;
		    result = (GFC_INTEGER_4)n + 1;
		  }
	      
	  }
	*dest = result;
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[0];
      dest += dstride[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];
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    {
	      /* Break out of the loop.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void sminloc1_4_s4 (gfc_array_i4 * const restrict, 
	gfc_array_s4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type);
export_proto(sminloc1_4_s4);

void
sminloc1_4_s4 (gfc_array_i4 * const restrict retarray, 
	gfc_array_s4 * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask , GFC_LOGICAL_4 back, gfc_charlen_type string_len)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
#ifdef HAVE_BACK_ARG
      minloc1_4_s4 (retarray, array, pdim, back, string_len);
#else
      minloc1_4_s4 (retarray, array, pdim, string_len);
#endif
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  if (unlikely (dim < 0 || dim > rank))
    {
      runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
 		     "is %ld, should be between 1 and %ld",
		     (long int) dim + 1, (long int) rank + 1);
    }

  for (n = 0; n < dim; n++)
    {
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  for (n = dim; n < rank; n++)
    {
      extent[n] =
	GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;

      if (extent[n] <= 0)
	extent[n] = 0;
    }

  if (retarray->base_addr == NULL)
    {
      size_t alloc_size, str;

      for (n = 0; n < rank; n++)
	{
	  if (n == 0)
	    str = 1;
	  else
	    str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];

	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);

	}

      retarray->offset = 0;
      GFC_DTYPE_COPY_SETRANK(retarray,array,rank);

      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
    }
  else
    {
      if (rank != GFC_DESCRIPTOR_RANK (retarray))
	runtime_error ("rank of return array incorrect in"
		       " MINLOC intrinsic: is %ld, should be %ld",
		       (long int) (GFC_DESCRIPTOR_RANK (retarray)),
		       (long int) rank);

      if (unlikely (compile_options.bounds_check))
	{
	  for (n=0; n < rank; n++)
	    {
	      index_type ret_extent;

	      ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	      if (extent[n] != ret_extent)
		runtime_error ("Incorrect extent in return value of"
			       " MINLOC intrinsic in dimension %ld:"
			       " is %ld, should be %ld", (long int) n + 1,
			       (long int) ret_extent, (long int) extent[n]);
	    }
	}
    }

  for (n = 0; n < rank; n++)
    {
      count[n] = 0;
      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
    }

  dest = retarray->base_addr;

  while(1)
    {
      *dest = 0;
      count[0]++;
      dest += dstride[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.  */
	  dest -= dstride[n] * extent[n];
	  n++;
	  if (n >= rank)
	    return;
	  else
	    {
	      count[n]++;
	      dest += dstride[n];
	    }
      	}
    }
}

#endif
Commit	Line	Data
ddc9995b	1	/* Implementation of the MINLOC 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
	28
	29	#if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
	30
64b1806b TK	31	#define HAVE_BACK_ARG 1
64b1806b TK	32
ddc9995b	33	#include <string.h>
64b1806b	34	#include <assert.h>
ddc9995b TK	35
	36	static inline int
	37	compare_fcn (const GFC_INTEGER_4 a, const GFC_INTEGER_4 b, gfc_charlen_type n)
	38	{
	39	if (sizeof (GFC_INTEGER_4) == 1)
	40	return memcmp (a, b, n);
	41	else
	42	return memcmp_char4 (a, b, n);
	43	}
	44
	45	extern void minloc1_4_s4 (gfc_array_i4 * const restrict,
64b1806b	46	gfc_array_s4 * const restrict, const index_type * const restrict , GFC_LOGICAL_4 back,
ddc9995b TK	47	gfc_charlen_type);
	48	export_proto(minloc1_4_s4);
	49
	50	void
	51	minloc1_4_s4 (gfc_array_i4 * const restrict retarray,
	52	gfc_array_s4 * const restrict array,
64b1806b TK	53	const index_type * const restrict pdim, GFC_LOGICAL_4 back,
64b1806b TK	54	gfc_charlen_type string_len)
ddc9995b TK	55	{
	56	index_type count[GFC_MAX_DIMENSIONS];
	57	index_type extent[GFC_MAX_DIMENSIONS];
	58	index_type sstride[GFC_MAX_DIMENSIONS];
	59	index_type dstride[GFC_MAX_DIMENSIONS];
	60	const GFC_INTEGER_4 * restrict base;
	61	GFC_INTEGER_4 * restrict dest;
	62	index_type rank;
	63	index_type n;
	64	index_type len;
	65	index_type delta;
	66	index_type dim;
	67	int continue_loop;
	68
64b1806b TK	69	#ifdef HAVE_BACK_ARG
	70	assert(back == 0);
	71	#endif
	72
ddc9995b TK	73	/* Make dim zero based to avoid confusion. */
	74	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	75	dim = (*pdim) - 1;
	76
	77	if (unlikely (dim < 0 \|\| dim > rank))
	78	{
	79	runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
	80	"is %ld, should be between 1 and %ld",
	81	(long int) dim + 1, (long int) rank + 1);
	82	}
	83
	84	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	85	if (len < 0)
	86	len = 0;
	87	delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
	88
	89	for (n = 0; n < dim; n++)
	90	{
	91	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
	92	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	93
	94	if (extent[n] < 0)
	95	extent[n] = 0;
	96	}
	97	for (n = dim; n < rank; n++)
	98	{
	99	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
	100	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	101
	102	if (extent[n] < 0)
	103	extent[n] = 0;
	104	}
	105
	106	if (retarray->base_addr == NULL)
	107	{
	108	size_t alloc_size, str;
	109
	110	for (n = 0; n < rank; n++)
	111	{
	112	if (n == 0)
	113	str = 1;
	114	else
	115	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	116
	117	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	118
	119	}
	120
	121	retarray->offset = 0;
fa3c4d47	122	GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
ddc9995b TK	123
	124	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
	125
	126	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
	127	if (alloc_size == 0)
	128	{
	129	/* Make sure we have a zero-sized array. */
	130	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	131	return;
	132
	133	}
	134	}
	135	else
	136	{
	137	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	138	runtime_error ("rank of return array incorrect in"
	139	" MINLOC intrinsic: is %ld, should be %ld",
	140	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	141	(long int) rank);
	142
	143	if (unlikely (compile_options.bounds_check))
	144	bounds_ifunction_return ((array_t *) retarray, extent,
	145	"return value", "MINLOC");
	146	}
	147
	148	for (n = 0; n < rank; n++)
	149	{
	150	count[n] = 0;
	151	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	152	if (extent[n] <= 0)
	153	return;
	154	}
	155
	156	base = array->base_addr;
	157	dest = retarray->base_addr;
	158
	159	continue_loop = 1;
	160	while (continue_loop)
	161	{
	162	const GFC_INTEGER_4 * restrict src;
	163	GFC_INTEGER_4 result;
	164	src = base;
	165	{
	166
	167	const GFC_INTEGER_4 *minval;
	168	minval = base;
	169	result = 1;
	170	if (len <= 0)
	171	*dest = 0;
	172	else
	173	{
	174	for (n = 0; n < len; n++, src += delta)
	175	{
	176
	177	if (compare_fcn (src, minval, string_len) < 0)
	178	{
	179	minval = src;
	180	result = (GFC_INTEGER_4)n + 1;
	181	}
	182	}
	183
	184	*dest = result;
	185	}
	186	}
187	/* Advance to the next element. */
188	count[0]++;
189	base += sstride[0];
190	dest += dstride[0];
191	n = 0;
192	while (count[n] == extent[n])
193	{
194	/* When we get to the end of a dimension, reset it and increment
195	the next dimension. */
196	count[n] = 0;
197	/* We could precalculate these products, but this is a less
198	frequently used path so probably not worth it. */
199	base -= sstride[n] * extent[n];
200	dest -= dstride[n] * extent[n];
201	n++;
202	if (n >= rank)
203	{
204	/* Break out of the loop. */
205	continue_loop = 0;
206	break;
207	}
208	else
209	{
210	count[n]++;
211	base += sstride[n];
212	dest += dstride[n];
213	}
214	}
215	}
216	}
217
218
219	extern void mminloc1_4_s4 (gfc_array_i4 * const restrict,
220	gfc_array_s4 * const restrict, const index_type * const restrict,
64b1806b	221	gfc_array_l1 * const restrict, GFC_LOGICAL_4 back, gfc_charlen_type);
ddc9995b TK	222	export_proto(mminloc1_4_s4);
	223
	224	void
	225	mminloc1_4_s4 (gfc_array_i4 * const restrict retarray,
	226	gfc_array_s4 * const restrict array,
	227	const index_type * const restrict pdim,
64b1806b TK	228	gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
64b1806b TK	229	gfc_charlen_type string_len)
ddc9995b TK	230	{
	231	index_type count[GFC_MAX_DIMENSIONS];
	232	index_type extent[GFC_MAX_DIMENSIONS];
	233	index_type sstride[GFC_MAX_DIMENSIONS];
	234	index_type dstride[GFC_MAX_DIMENSIONS];
	235	index_type mstride[GFC_MAX_DIMENSIONS];
	236	GFC_INTEGER_4 * restrict dest;
	237	const GFC_INTEGER_4 * restrict base;
	238	const GFC_LOGICAL_1 * restrict mbase;
	239	index_type rank;
	240	index_type dim;
	241	index_type n;
	242	index_type len;
	243	index_type delta;
	244	index_type mdelta;
	245	int mask_kind;
	246
64b1806b TK	247	#ifdef HAVE_BACK_ARG
	248	assert (back == 0);
	249	#endif
ddc9995b TK	250	dim = (*pdim) - 1;
	251	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	252
	253
	254	if (unlikely (dim < 0 \|\| dim > rank))
	255	{
	256	runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
	257	"is %ld, should be between 1 and %ld",
	258	(long int) dim + 1, (long int) rank + 1);
	259	}
	260
	261	len = GFC_DESCRIPTOR_EXTENT(array,dim);
	262	if (len <= 0)
	263	return;
	264
	265	mbase = mask->base_addr;
	266
	267	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	268
	269	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	270	#ifdef HAVE_GFC_LOGICAL_16
	271	\|\| mask_kind == 16
	272	#endif
	273	)
	274	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	275	else
	276	runtime_error ("Funny sized logical array");
	277
	278	delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
	279	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
	280
	281	for (n = 0; n < dim; n++)
	282	{
	283	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
	284	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	285	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
	286
	287	if (extent[n] < 0)
	288	extent[n] = 0;
	289
	290	}
	291	for (n = dim; n < rank; n++)
	292	{
	293	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
	294	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	295	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
	296
	297	if (extent[n] < 0)
	298	extent[n] = 0;
	299	}
	300
	301	if (retarray->base_addr == NULL)
	302	{
	303	size_t alloc_size, str;
	304
	305	for (n = 0; n < rank; n++)
	306	{
	307	if (n == 0)
	308	str = 1;
	309	else
	310	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	311
	312	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	313
314	}
315
316	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
317
318	retarray->offset = 0;
fa3c4d47	319	GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
ddc9995b TK	320
	321	if (alloc_size == 0)
	322	{
	323	/* Make sure we have a zero-sized array. */
	324	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	325	return;
	326	}
	327	else
	328	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
	329
	330	}
	331	else
	332	{
	333	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	334	runtime_error ("rank of return array incorrect in MINLOC intrinsic");
	335
	336	if (unlikely (compile_options.bounds_check))
	337	{
	338	bounds_ifunction_return ((array_t *) retarray, extent,
	339	"return value", "MINLOC");
	340	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	341	"MASK argument", "MINLOC");
	342	}
	343	}
	344
	345	for (n = 0; n < rank; n++)
	346	{
	347	count[n] = 0;
	348	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	349	if (extent[n] <= 0)
	350	return;
	351	}
	352
	353	dest = retarray->base_addr;
	354	base = array->base_addr;
	355
	356	while (base)
	357	{
	358	const GFC_INTEGER_4 * restrict src;
	359	const GFC_LOGICAL_1 * restrict msrc;
	360	GFC_INTEGER_4 result;
	361	src = base;
	362	msrc = mbase;
	363	{
	364
	365	const GFC_INTEGER_4 *minval;
	366	minval = base;
	367	result = 0;
	368	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	369	{
	370
	371	if (*msrc)
	372	{
	373	minval = src;
	374	result = (GFC_INTEGER_4)n + 1;
	375	break;
	376	}
	377	}
	378	for (; n < len; n++, src += delta, msrc += mdelta)
	379	{
	380	if (*msrc && compare_fcn (src, minval, string_len) < 0)
	381	{
	382	minval = src;
	383	result = (GFC_INTEGER_4)n + 1;
384	}
385
386	}
387	*dest = result;
388	}
389	/* Advance to the next element. */
390	count[0]++;
391	base += sstride[0];
392	mbase += mstride[0];
393	dest += dstride[0];
394	n = 0;
395	while (count[n] == extent[n])
396	{
397	/* When we get to the end of a dimension, reset it and increment
398	the next dimension. */
399	count[n] = 0;
400	/* We could precalculate these products, but this is a less
401	frequently used path so probably not worth it. */
402	base -= sstride[n] * extent[n];
403	mbase -= mstride[n] * extent[n];
404	dest -= dstride[n] * extent[n];
405	n++;
406	if (n >= rank)
407	{
408	/* Break out of the loop. */
409	base = NULL;
410	break;
411	}
412	else
413	{
414	count[n]++;
415	base += sstride[n];
416	mbase += mstride[n];
417	dest += dstride[n];
418	}
419	}
420	}
421	}
422
423
424	extern void sminloc1_4_s4 (gfc_array_i4 * const restrict,
425	gfc_array_s4 * const restrict, const index_type * const restrict,
64b1806b	426	GFC_LOGICAL_4 *, GFC_LOGICAL_4 back, gfc_charlen_type);
ddc9995b TK	427	export_proto(sminloc1_4_s4);
	428
	429	void
	430	sminloc1_4_s4 (gfc_array_i4 * const restrict retarray,
	431	gfc_array_s4 * const restrict array,
	432	const index_type * const restrict pdim,
64b1806b	433	GFC_LOGICAL_4 * mask , GFC_LOGICAL_4 back, gfc_charlen_type string_len)
ddc9995b TK	434	{
	435	index_type count[GFC_MAX_DIMENSIONS];
	436	index_type extent[GFC_MAX_DIMENSIONS];
	437	index_type dstride[GFC_MAX_DIMENSIONS];
	438	GFC_INTEGER_4 * restrict dest;
	439	index_type rank;
	440	index_type n;
	441	index_type dim;
	442
	443
	444	if (*mask)
	445	{
64b1806b TK	446	#ifdef HAVE_BACK_ARG
	447	minloc1_4_s4 (retarray, array, pdim, back, string_len);
	448	#else
ddc9995b	449	minloc1_4_s4 (retarray, array, pdim, string_len);
64b1806b	450	#endif
ddc9995b TK	451	return;
	452	}
	453	/* Make dim zero based to avoid confusion. */
	454	dim = (*pdim) - 1;
	455	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	456
	457	if (unlikely (dim < 0 \|\| dim > rank))
	458	{
	459	runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
	460	"is %ld, should be between 1 and %ld",
	461	(long int) dim + 1, (long int) rank + 1);
	462	}
	463
	464	for (n = 0; n < dim; n++)
	465	{
	466	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
	467
	468	if (extent[n] <= 0)
	469	extent[n] = 0;
	470	}
	471
	472	for (n = dim; n < rank; n++)
	473	{
	474	extent[n] =
	475	GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
	476
	477	if (extent[n] <= 0)
	478	extent[n] = 0;
	479	}
	480
	481	if (retarray->base_addr == NULL)
	482	{
	483	size_t alloc_size, str;
	484
	485	for (n = 0; n < rank; n++)
	486	{
	487	if (n == 0)
	488	str = 1;
	489	else
	490	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	491
	492	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	493
	494	}
	495
	496	retarray->offset = 0;
fa3c4d47	497	GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
ddc9995b TK	498
	499	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
	500
	501	if (alloc_size == 0)
	502	{
	503	/* Make sure we have a zero-sized array. */
	504	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	505	return;
	506	}
	507	else
	508	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
	509	}
	510	else
	511	{
	512	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	513	runtime_error ("rank of return array incorrect in"
	514	" MINLOC intrinsic: is %ld, should be %ld",
	515	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	516	(long int) rank);
	517
	518	if (unlikely (compile_options.bounds_check))
	519	{
	520	for (n=0; n < rank; n++)
	521	{
	522	index_type ret_extent;
	523
	524	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
	525	if (extent[n] != ret_extent)
	526	runtime_error ("Incorrect extent in return value of"
	527	" MINLOC intrinsic in dimension %ld:"
	528	" is %ld, should be %ld", (long int) n + 1,
	529	(long int) ret_extent, (long int) extent[n]);
	530	}
	531	}
	532	}
	533
	534	for (n = 0; n < rank; n++)
	535	{
	536	count[n] = 0;
	537	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
	538	}
	539
	540	dest = retarray->base_addr;
	541
	542	while(1)
	543	{
	544	*dest = 0;
	545	count[0]++;
	546	dest += dstride[0];
	547	n = 0;
	548	while (count[n] == extent[n])
	549	{
	550	/* When we get to the end of a dimension, reset it and increment
	551	the next dimension. */
	552	count[n] = 0;
	553	/* We could precalculate these products, but this is a less
	554	frequently used path so probably not worth it. */
	555	dest -= dstride[n] * extent[n];
	556	n++;
	557	if (n >= rank)
	558	return;
	559	else
	560	{
	561	count[n]++;
562	dest += dstride[n];
563	}
564	}
565	}
566	}
567
568	#endif