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

/* Implementation of the MINLOC intrinsic
   Copyright (C) 2002-2018 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

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_1) && defined (HAVE_GFC_INTEGER_4)


extern void minloc1_4_i1 (gfc_array_i4 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict);
export_proto(minloc1_4_i1);

void
minloc1_4_i1 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i1 * const restrict array, 
	const index_type * const restrict pdim)
{
  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_1 * 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);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,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);
      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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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_1 * restrict src;
      GFC_INTEGER_4 result;
      src = base;
      {

	GFC_INTEGER_1 minval;
#if defined (GFC_INTEGER_1_INFINITY)
	minval = GFC_INTEGER_1_INFINITY;
#else
	minval = GFC_INTEGER_1_HUGE;
#endif
	result = 1;
	if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

#if defined (GFC_INTEGER_1_QUIET_NAN)
		if (*src <= minval)
		  {
		    minval = *src;
		    result = (GFC_INTEGER_4)n + 1;
		    break;
		  }
	      }
	    for (; n < len; n++, src += delta)
	      {
#endif
		if (*src < minval)
		  {
		    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_i1 (gfc_array_i4 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mminloc1_4_i1);

void
mminloc1_4_i1 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i1 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_4 * restrict dest;
  const GFC_INTEGER_1 * 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;

  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);
  mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      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);
      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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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_1 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_4 result;
      src = base;
      msrc = mbase;
      {

	GFC_INTEGER_1 minval;
#if defined (GFC_INTEGER_1_INFINITY)
	minval = GFC_INTEGER_1_INFINITY;
#else
	minval = GFC_INTEGER_1_HUGE;
#endif
#if defined (GFC_INTEGER_1_QUIET_NAN)
	GFC_INTEGER_4 result2 = 0;
#endif
	result = 0;
	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	  {

		if (*msrc)
		  {
#if defined (GFC_INTEGER_1_QUIET_NAN)
		    if (!result2)
		      result2 = (GFC_INTEGER_4)n + 1;
		    if (*src <= minval)
#endif
		      {
			minval = *src;
			result = (GFC_INTEGER_4)n + 1;
			break;
		      }
		  }
	      }
#if defined (GFC_INTEGER_1_QUIET_NAN)
	    if (unlikely (n >= len))
	      result = result2;
	    else
#endif
	    for (; n < len; n++, src += delta, msrc += mdelta)
	      {
		if (*msrc && *src < minval)
		  {
		    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_i1 (gfc_array_i4 * const restrict, 
	gfc_array_i1 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sminloc1_4_i1);

void
sminloc1_4_i1 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i1 * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask)
{
  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)
    {
      minloc1_4_i1 (retarray, array, pdim);
      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);

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

  for (n = dim; n < rank; n++)
    {
      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 = (array->dtype & ~GFC_DTYPE_RANK_MASK) | 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
567c915b	1	/* Implementation of the MINLOC intrinsic
85ec4feb	2	Copyright (C) 2002-2018 Free Software Foundation, Inc.
567c915b TK	3	Contributed by Paul Brook <paul@nowt.org>
567c915b TK	4
0cd0559e	5	This file is part of the GNU Fortran runtime library (libgfortran).
567c915b TK	6
	7	Libgfortran is free software; you can redistribute it and/or
	8	modify it under the terms of the GNU General Public
	9	License as published by the Free Software Foundation; either
748086b7	10	version 3 of the License, or (at your option) any later version.
567c915b TK	11
	12	Libgfortran is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
	16
748086b7 JJ	17	Under Section 7 of GPL version 3, you are granted additional
	18	permissions described in the GCC Runtime Library Exception, version
	19	3.1, as published by the Free Software Foundation.
	20
	21	You should have received a copy of the GNU General Public License and
	22	a copy of the GCC Runtime Library Exception along with this program;
	23	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	24	<http://www.gnu.org/licenses/>. */
567c915b	25
36ae8a61	26	#include "libgfortran.h"
567c915b TK	27
	28
	29	#if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
	30
	31
	32	extern void minloc1_4_i1 (gfc_array_i4 * const restrict,
	33	gfc_array_i1 * const restrict, const index_type * const restrict);
	34	export_proto(minloc1_4_i1);
	35
	36	void
	37	minloc1_4_i1 (gfc_array_i4 * const restrict retarray,
	38	gfc_array_i1 * const restrict array,
	39	const index_type * const restrict pdim)
	40	{
	41	index_type count[GFC_MAX_DIMENSIONS];
	42	index_type extent[GFC_MAX_DIMENSIONS];
	43	index_type sstride[GFC_MAX_DIMENSIONS];
	44	index_type dstride[GFC_MAX_DIMENSIONS];
	45	const GFC_INTEGER_1 * restrict base;
	46	GFC_INTEGER_4 * restrict dest;
	47	index_type rank;
	48	index_type n;
	49	index_type len;
	50	index_type delta;
	51	index_type dim;
da96f5ab	52	int continue_loop;
567c915b TK	53
567c915b TK	54	/* Make dim zero based to avoid confusion. */
567c915b	55	rank = GFC_DESCRIPTOR_RANK (array) - 1;
cfdf6ff6 TK	56	dim = (*pdim) - 1;
	57
	58	if (unlikely (dim < 0 \|\| dim > rank))
	59	{
	60	runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
	61	"is %ld, should be between 1 and %ld",
	62	(long int) dim + 1, (long int) rank + 1);
	63	}
567c915b	64
dfb55fdc	65	len = GFC_DESCRIPTOR_EXTENT(array,dim);
da96f5ab TK	66	if (len < 0)
da96f5ab TK	67	len = 0;
dfb55fdc	68	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
567c915b TK	69
	70	for (n = 0; n < dim; n++)
	71	{
dfb55fdc TK	72	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
dfb55fdc TK	73	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
567c915b TK	74
	75	if (extent[n] < 0)
	76	extent[n] = 0;
	77	}
	78	for (n = dim; n < rank; n++)
	79	{
dfb55fdc TK	80	sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
dfb55fdc TK	81	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
567c915b TK	82
	83	if (extent[n] < 0)
	84	extent[n] = 0;
	85	}
	86
21d1335b	87	if (retarray->base_addr == NULL)
567c915b	88	{
dfb55fdc	89	size_t alloc_size, str;
567c915b TK	90
567c915b TK	91	for (n = 0; n < rank; n++)
80927a56 JJ	92	{
80927a56 JJ	93	if (n == 0)
dfb55fdc	94	str = 1;
80927a56 JJ	95	else
80927a56 JJ	96	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	97
	98	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	99
80927a56	100	}
567c915b TK	101
	102	retarray->offset = 0;
	103	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	104
92e6f3a4	105	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
567c915b	106
92e6f3a4	107	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
567c915b TK	108	if (alloc_size == 0)
	109	{
	110	/* Make sure we have a zero-sized array. */
dfb55fdc	111	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
567c915b	112	return;
dfb55fdc	113
567c915b	114	}
567c915b TK	115	}
	116	else
	117	{
	118	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8	119	runtime_error ("rank of return array incorrect in"
ccacefc7 TK	120	" MINLOC intrinsic: is %ld, should be %ld",
	121	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	122	(long int) rank);
fd6590f8	123
9731c4a3	124	if (unlikely (compile_options.bounds_check))
16bff921 TK	125	bounds_ifunction_return ((array_t *) retarray, extent,
16bff921 TK	126	"return value", "MINLOC");
567c915b TK	127	}
	128
	129	for (n = 0; n < rank; n++)
	130	{
	131	count[n] = 0;
dfb55fdc	132	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
567c915b	133	if (extent[n] <= 0)
facc1285	134	return;
567c915b TK	135	}
567c915b TK	136
21d1335b TB	137	base = array->base_addr;
21d1335b TB	138	dest = retarray->base_addr;
567c915b	139
da96f5ab TK	140	continue_loop = 1;
da96f5ab TK	141	while (continue_loop)
567c915b TK	142	{
	143	const GFC_INTEGER_1 * restrict src;
	144	GFC_INTEGER_4 result;
	145	src = base;
	146	{
	147
80927a56 JJ	148	GFC_INTEGER_1 minval;
	149	#if defined (GFC_INTEGER_1_INFINITY)
	150	minval = GFC_INTEGER_1_INFINITY;
	151	#else
	152	minval = GFC_INTEGER_1_HUGE;
	153	#endif
	154	result = 1;
	155	if (len <= 0)
567c915b TK	156	*dest = 0;
	157	else
	158	{
	159	for (n = 0; n < len; n++, src += delta)
	160	{
	161
80927a56 JJ	162	#if defined (GFC_INTEGER_1_QUIET_NAN)
	163	if (*src <= minval)
	164	{
	165	minval = *src;
	166	result = (GFC_INTEGER_4)n + 1;
	167	break;
	168	}
	169	}
	170	for (; n < len; n++, src += delta)
	171	{
	172	#endif
	173	if (*src < minval)
	174	{
	175	minval = *src;
	176	result = (GFC_INTEGER_4)n + 1;
	177	}
	178	}
0cd0559e	179
567c915b TK	180	*dest = result;
	181	}
	182	}
	183	/* Advance to the next element. */
	184	count[0]++;
	185	base += sstride[0];
	186	dest += dstride[0];
	187	n = 0;
	188	while (count[n] == extent[n])
80927a56 JJ	189	{
	190	/* When we get to the end of a dimension, reset it and increment
	191	the next dimension. */
	192	count[n] = 0;
	193	/* We could precalculate these products, but this is a less
	194	frequently used path so probably not worth it. */
	195	base -= sstride[n] * extent[n];
	196	dest -= dstride[n] * extent[n];
	197	n++;
80dd631f	198	if (n >= rank)
80927a56	199	{
80dd631f	200	/* Break out of the loop. */
da96f5ab TK	201	continue_loop = 0;
da96f5ab TK	202	break;
80927a56 JJ	203	}
	204	else
	205	{
	206	count[n]++;
	207	base += sstride[n];
	208	dest += dstride[n];
	209	}
	210	}
567c915b TK	211	}
	212	}
	213
	214
	215	extern void mminloc1_4_i1 (gfc_array_i4 * const restrict,
	216	gfc_array_i1 * const restrict, const index_type * const restrict,
28dc6b33	217	gfc_array_l1 * const restrict);
567c915b TK	218	export_proto(mminloc1_4_i1);
	219
	220	void
	221	mminloc1_4_i1 (gfc_array_i4 * const restrict retarray,
	222	gfc_array_i1 * const restrict array,
	223	const index_type * const restrict pdim,
28dc6b33	224	gfc_array_l1 * const restrict mask)
567c915b TK	225	{
	226	index_type count[GFC_MAX_DIMENSIONS];
	227	index_type extent[GFC_MAX_DIMENSIONS];
	228	index_type sstride[GFC_MAX_DIMENSIONS];
	229	index_type dstride[GFC_MAX_DIMENSIONS];
	230	index_type mstride[GFC_MAX_DIMENSIONS];
	231	GFC_INTEGER_4 * restrict dest;
	232	const GFC_INTEGER_1 * restrict base;
28dc6b33	233	const GFC_LOGICAL_1 * restrict mbase;
cfdf6ff6 TK	234	index_type rank;
cfdf6ff6 TK	235	index_type dim;
567c915b TK	236	index_type n;
	237	index_type len;
	238	index_type delta;
	239	index_type mdelta;
28dc6b33	240	int mask_kind;
567c915b TK	241
	242	dim = (*pdim) - 1;
	243	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	244
cfdf6ff6 TK	245
	246	if (unlikely (dim < 0 \|\| dim > rank))
	247	{
	248	runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
	249	"is %ld, should be between 1 and %ld",
	250	(long int) dim + 1, (long int) rank + 1);
	251	}
	252
dfb55fdc	253	len = GFC_DESCRIPTOR_EXTENT(array,dim);
567c915b TK	254	if (len <= 0)
567c915b TK	255	return;
28dc6b33	256
21d1335b	257	mbase = mask->base_addr;
28dc6b33 TK	258
	259	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	260
	261	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	262	#ifdef HAVE_GFC_LOGICAL_16
	263	\|\| mask_kind == 16
	264	#endif
	265	)
	266	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	267	else
	268	runtime_error ("Funny sized logical array");
	269
dfb55fdc TK	270	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
dfb55fdc TK	271	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
567c915b TK	272
	273	for (n = 0; n < dim; n++)
	274	{
dfb55fdc TK	275	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	276	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	277	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
567c915b TK	278
	279	if (extent[n] < 0)
	280	extent[n] = 0;
	281
	282	}
	283	for (n = dim; n < rank; n++)
	284	{
dfb55fdc TK	285	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
	286	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	287	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
567c915b TK	288
	289	if (extent[n] < 0)
	290	extent[n] = 0;
	291	}
	292
21d1335b	293	if (retarray->base_addr == NULL)
567c915b	294	{
dfb55fdc	295	size_t alloc_size, str;
567c915b TK	296
567c915b TK	297	for (n = 0; n < rank; n++)
80927a56 JJ	298	{
	299	if (n == 0)
	300	str = 1;
	301	else
	302	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	303
	304	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	305
80927a56	306	}
567c915b	307
92e6f3a4	308	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
567c915b TK	309
	310	retarray->offset = 0;
	311	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
	312
	313	if (alloc_size == 0)
	314	{
	315	/* Make sure we have a zero-sized array. */
dfb55fdc	316	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
567c915b TK	317	return;
	318	}
	319	else
92e6f3a4	320	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
567c915b TK	321
	322	}
	323	else
	324	{
	325	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8 TK	326	runtime_error ("rank of return array incorrect in MINLOC intrinsic");
fd6590f8 TK	327
9731c4a3	328	if (unlikely (compile_options.bounds_check))
fd6590f8	329	{
16bff921 TK	330	bounds_ifunction_return ((array_t *) retarray, extent,
	331	"return value", "MINLOC");
	332	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	333	"MASK argument", "MINLOC");
fd6590f8	334	}
567c915b TK	335	}
	336
	337	for (n = 0; n < rank; n++)
	338	{
	339	count[n] = 0;
dfb55fdc	340	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
567c915b	341	if (extent[n] <= 0)
80927a56	342	return;
567c915b TK	343	}
567c915b TK	344
21d1335b TB	345	dest = retarray->base_addr;
21d1335b TB	346	base = array->base_addr;
567c915b TK	347
	348	while (base)
	349	{
	350	const GFC_INTEGER_1 * restrict src;
28dc6b33	351	const GFC_LOGICAL_1 * restrict msrc;
567c915b TK	352	GFC_INTEGER_4 result;
	353	src = base;
	354	msrc = mbase;
	355	{
	356
80927a56 JJ	357	GFC_INTEGER_1 minval;
	358	#if defined (GFC_INTEGER_1_INFINITY)
	359	minval = GFC_INTEGER_1_INFINITY;
	360	#else
	361	minval = GFC_INTEGER_1_HUGE;
	362	#endif
	363	#if defined (GFC_INTEGER_1_QUIET_NAN)
	364	GFC_INTEGER_4 result2 = 0;
	365	#endif
	366	result = 0;
036e1775	367	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
567c915b	368	{
567c915b	369
80927a56 JJ	370	if (*msrc)
	371	{
	372	#if defined (GFC_INTEGER_1_QUIET_NAN)
	373	if (!result2)
	374	result2 = (GFC_INTEGER_4)n + 1;
	375	if (*src <= minval)
	376	#endif
	377	{
	378	minval = *src;
	379	result = (GFC_INTEGER_4)n + 1;
	380	break;
	381	}
	382	}
	383	}
	384	#if defined (GFC_INTEGER_1_QUIET_NAN)
	385	if (unlikely (n >= len))
	386	result = result2;
	387	else
	388	#endif
	389	for (; n < len; n++, src += delta, msrc += mdelta)
	390	{
	391	if (msrc && src < minval)
	392	{
	393	minval = *src;
	394	result = (GFC_INTEGER_4)n + 1;
	395	}
567c915b	396	}
036e1775	397	*dest = result;
567c915b TK	398	}
	399	/* Advance to the next element. */
	400	count[0]++;
	401	base += sstride[0];
	402	mbase += mstride[0];
	403	dest += dstride[0];
	404	n = 0;
	405	while (count[n] == extent[n])
80927a56 JJ	406	{
	407	/* When we get to the end of a dimension, reset it and increment
	408	the next dimension. */
	409	count[n] = 0;
	410	/* We could precalculate these products, but this is a less
	411	frequently used path so probably not worth it. */
	412	base -= sstride[n] * extent[n];
	413	mbase -= mstride[n] * extent[n];
	414	dest -= dstride[n] * extent[n];
	415	n++;
80dd631f	416	if (n >= rank)
80927a56	417	{
80dd631f	418	/* Break out of the loop. */
80927a56 JJ	419	base = NULL;
	420	break;
	421	}
	422	else
	423	{
	424	count[n]++;
	425	base += sstride[n];
	426	mbase += mstride[n];
	427	dest += dstride[n];
	428	}
	429	}
567c915b TK	430	}
	431	}
	432
	433
	434	extern void sminloc1_4_i1 (gfc_array_i4 * const restrict,
	435	gfc_array_i1 * const restrict, const index_type * const restrict,
	436	GFC_LOGICAL_4 *);
	437	export_proto(sminloc1_4_i1);
	438
	439	void
	440	sminloc1_4_i1 (gfc_array_i4 * const restrict retarray,
	441	gfc_array_i1 * const restrict array,
	442	const index_type * const restrict pdim,
	443	GFC_LOGICAL_4 * mask)
	444	{
802367d7 TK	445	index_type count[GFC_MAX_DIMENSIONS];
802367d7 TK	446	index_type extent[GFC_MAX_DIMENSIONS];
802367d7 TK	447	index_type dstride[GFC_MAX_DIMENSIONS];
802367d7 TK	448	GFC_INTEGER_4 * restrict dest;
567c915b TK	449	index_type rank;
567c915b TK	450	index_type n;
802367d7 TK	451	index_type dim;
802367d7 TK	452
567c915b TK	453
	454	if (*mask)
	455	{
	456	minloc1_4_i1 (retarray, array, pdim);
	457	return;
	458	}
802367d7 TK	459	/* Make dim zero based to avoid confusion. */
	460	dim = (*pdim) - 1;
	461	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	462
cfdf6ff6 TK	463	if (unlikely (dim < 0 \|\| dim > rank))
	464	{
	465	runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
	466	"is %ld, should be between 1 and %ld",
	467	(long int) dim + 1, (long int) rank + 1);
	468	}
	469
802367d7 TK	470	for (n = 0; n < dim; n++)
802367d7 TK	471	{
dfb55fdc	472	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
802367d7 TK	473
	474	if (extent[n] <= 0)
	475	extent[n] = 0;
	476	}
	477
	478	for (n = dim; n < rank; n++)
	479	{
802367d7	480	extent[n] =
80927a56	481	GFC_DESCRIPTOR_EXTENT(array,n + 1);
802367d7 TK	482
802367d7 TK	483	if (extent[n] <= 0)
80927a56	484	extent[n] = 0;
802367d7	485	}
567c915b	486
21d1335b	487	if (retarray->base_addr == NULL)
567c915b	488	{
dfb55fdc	489	size_t alloc_size, str;
802367d7 TK	490
802367d7 TK	491	for (n = 0; n < rank; n++)
80927a56 JJ	492	{
	493	if (n == 0)
	494	str = 1;
	495	else
	496	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
dfb55fdc TK	497
	498	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	499
80927a56	500	}
802367d7	501
567c915b	502	retarray->offset = 0;
802367d7 TK	503	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
802367d7 TK	504
92e6f3a4	505	alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
802367d7 TK	506
	507	if (alloc_size == 0)
	508	{
	509	/* Make sure we have a zero-sized array. */
dfb55fdc	510	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
802367d7 TK	511	return;
	512	}
	513	else
92e6f3a4	514	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
567c915b TK	515	}
	516	else
	517	{
802367d7 TK	518	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	519	runtime_error ("rank of return array incorrect in"
	520	" MINLOC intrinsic: is %ld, should be %ld",
	521	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	522	(long int) rank);
	523
9731c4a3	524	if (unlikely (compile_options.bounds_check))
fd6590f8	525	{
802367d7 TK	526	for (n=0; n < rank; n++)
	527	{
	528	index_type ret_extent;
567c915b	529
dfb55fdc	530	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
802367d7 TK	531	if (extent[n] != ret_extent)
	532	runtime_error ("Incorrect extent in return value of"
	533	" MINLOC intrinsic in dimension %ld:"
	534	" is %ld, should be %ld", (long int) n + 1,
	535	(long int) ret_extent, (long int) extent[n]);
	536	}
fd6590f8 TK	537	}
fd6590f8 TK	538	}
567c915b	539
802367d7 TK	540	for (n = 0; n < rank; n++)
	541	{
	542	count[n] = 0;
dfb55fdc	543	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
802367d7 TK	544	}
802367d7 TK	545
21d1335b	546	dest = retarray->base_addr;
802367d7 TK	547
	548	while(1)
	549	{
	550	*dest = 0;
	551	count[0]++;
	552	dest += dstride[0];
	553	n = 0;
	554	while (count[n] == extent[n])
80927a56	555	{
802367d7	556	/* When we get to the end of a dimension, reset it and increment
80927a56 JJ	557	the next dimension. */
	558	count[n] = 0;
	559	/* We could precalculate these products, but this is a less
	560	frequently used path so probably not worth it. */
	561	dest -= dstride[n] * extent[n];
	562	n++;
80dd631f	563	if (n >= rank)
802367d7	564	return;
80927a56 JJ	565	else
	566	{
	567	count[n]++;
	568	dest += dstride[n];
	569	}
802367d7 TK	570	}
802367d7 TK	571	}
567c915b TK	572	}
	573
	574	#endif