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

/* Implementation of the MINLOC intrinsic
   Copyright (C) 2017-2020 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_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4)

#define HAVE_BACK_ARG 1

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

static inline int
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
{
  if (sizeof (GFC_UINTEGER_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_UINTEGER_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;

  /* 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;
      retarray->dtype.rank = 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_UINTEGER_4 * restrict src;
      GFC_INTEGER_4 result;
      src = base;
      {

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

		if (minval == NULL || (back ? compare_fcn (src, minval, string_len) <= 0 :
		   	      	      	      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_UINTEGER_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;

  if (mask == NULL)
    {
#ifdef HAVE_BACK_ARG
      minloc1_4_s4 (retarray, array, pdim, back, string_len);
#else
      minloc1_4_s4 (retarray, array, pdim, string_len);
#endif
      return;
    }

  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;
      retarray->dtype.rank = 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_UINTEGER_4 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_4 result;
      src = base;
      msrc = mbase;
      {

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