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

/* Implementation of the MINLOC intrinsic
   Copyright (C) 2002-2017 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.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 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;
  int rank;
  int 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;

  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;

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