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

/* Implementation of the MINLOC intrinsic
   Copyright 2002, 2007, 2009, 2010 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"
#include <stdlib.h>
#include <assert.h>
#include <limits.h>


#if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_16)


extern void minloc1_16_r4 (gfc_array_i16 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict);
export_proto(minloc1_16_r4);

void
minloc1_16_r4 (gfc_array_i16 * const restrict retarray, 
	gfc_array_r4 * 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_REAL_4 * restrict base;
  GFC_INTEGER_16 * 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->data == 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 = sizeof (GFC_INTEGER_16) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
    		   * extent[rank-1];

      retarray->data = internal_malloc_size (alloc_size);
      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->data;
  dest = retarray->data;

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

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

#if defined (GFC_REAL_4_QUIET_NAN)
		if (*src <= minval)
		  {
		    minval = *src;
		    result = (GFC_INTEGER_16)n + 1;
		    break;
		  }
	      }
	    for (; n < len; n++, src += delta)
	      {
#endif
		if (*src < minval)
		  {
		    minval = *src;
		    result = (GFC_INTEGER_16)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 look.  */
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void mminloc1_16_r4 (gfc_array_i16 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mminloc1_16_r4);

void
mminloc1_16_r4 (gfc_array_i16 * const restrict retarray, 
	gfc_array_r4 * 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_16 * restrict dest;
  const GFC_REAL_4 * 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->data;

  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->data == 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 = sizeof (GFC_INTEGER_16) * 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->data = internal_malloc_size (alloc_size);

    }
  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->data;
  base = array->data;

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

	GFC_REAL_4 minval;
#if defined (GFC_REAL_4_INFINITY)
	minval = GFC_REAL_4_INFINITY;
#else
	minval = GFC_REAL_4_HUGE;
#endif
#if defined (GFC_REAL_4_QUIET_NAN)
	GFC_INTEGER_16 result2 = 0;
#endif
	result = 0;
	if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

		if (*msrc)
		  {
#if defined (GFC_REAL_4_QUIET_NAN)
		    if (!result2)
		      result2 = (GFC_INTEGER_16)n + 1;
		    if (*src <= minval)
#endif
		      {
			minval = *src;
			result = (GFC_INTEGER_16)n + 1;
			break;
		      }
		  }
	      }
#if defined (GFC_REAL_4_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_16)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 look.  */
	      base = NULL;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	      mbase += mstride[n];
	      dest += dstride[n];
	    }
	}
    }
}


extern void sminloc1_16_r4 (gfc_array_i16 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sminloc1_16_r4);

void
sminloc1_16_r4 (gfc_array_i16 * const restrict retarray, 
	gfc_array_r4 * 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_16 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      minloc1_16_r4 (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->data == 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 = sizeof (GFC_INTEGER_16) * 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->data = internal_malloc_size (alloc_size);
    }
  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->data;

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