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

/* Implementation of the MINLOC intrinsic
   Copyright (C) 2002-2024 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 <assert.h>


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

#define HAVE_BACK_ARG 1


extern void minloc1_16_r4 (gfc_array_i16 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
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, GFC_LOGICAL_4 back)
{
  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.  */
  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.rank = rank;

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

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
      if (alloc_size == 0)
	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_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
	  {
#if ! defined HAVE_BACK_ARG
	    for (n = 0; n < len; n++, src += delta)
	      {
#endif

#if defined (GFC_REAL_4_QUIET_NAN)
     	   for (n = 0; n < len; n++, src += delta)
	     {
		if (*src <= minval)
		  {
		    minval = *src;
		    result = (GFC_INTEGER_16)n + 1;
		    break;
		  }
	      }
#else
	    n = 0;
#endif
	    if (back)
	      for (; n < len; n++, src += delta)
	        {
		  if (unlikely (*src <= minval))
		    {
		      minval = *src;
		      result = (GFC_INTEGER_16)n + 1;
		    }
		}
	    else
	      for (; n < len; n++, src += delta)
	        {
		  if (unlikely (*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 loop.  */
	      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, GFC_LOGICAL_4 back);
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, GFC_LOGICAL_4 back)
{
  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;
  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_16_r4 (retarray, array, pdim, back);
#else
      minloc1_16_r4 (retarray, array, pdim);
#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)
    len = 0;

  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.rank = rank;

      retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
      if (alloc_size == 0)
	return;
    }
  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_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;
	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
	    if (back)
	      for (; n < len; n++, src += delta, msrc += mdelta)
	      	{
		  if (*msrc && unlikely (*src <= minval))
		    {
		      minval = *src;
		      result = (GFC_INTEGER_16)n + 1;
		    }
		}
	      else
	        for (; n < len; n++, src += delta, msrc += mdelta)
		  {
		    if (*msrc && unlikely (*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 loop.  */
	      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 *, GFC_LOGICAL_4 back);
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, GFC_LOGICAL_4 back)
{
  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 == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      minloc1_16_r4 (retarray, array, pdim, back);
#else
      minloc1_16_r4 (retarray, array, pdim);
#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);

      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.rank = rank;

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

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