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

/* Implementation of the MINLOC intrinsic
   Copyright (C) 2002-2020 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_8)

#define HAVE_BACK_ARG 1


extern void minloc1_8_r4 (gfc_array_i8 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
export_proto(minloc1_8_r4);

void
minloc1_8_r4 (gfc_array_i8 * 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_8 * 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_8));
      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_REAL_4 * restrict src;
      GFC_INTEGER_8 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_8)n + 1;
		    break;
		  }
	      }
#else
	    n = 0;
#endif
	    if (back)
	      for (; n < len; n++, src += delta)
	        {
		  if (unlikely (*src <= minval))
		    {
		      minval = *src;
		      result = (GFC_INTEGER_8)n + 1;
		    }
		}
	    else
	      for (; n < len; n++, src += delta)
	        {
		  if (unlikely (*src < minval))
		    {
		      minval = *src;
		      result = (GFC_INTEGER_8) 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_8_r4 (gfc_array_i8 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
export_proto(mminloc1_8_r4);

void
mminloc1_8_r4 (gfc_array_i8 * 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_8 * 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_8_r4 (retarray, array, pdim, back);
#else
      minloc1_8_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)
    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.rank = rank;

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
	  return;
	}
      else
	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));

    }
  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_8 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_8 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_8)n + 1;
		    if (*src <= minval)
#endif
		      {
			minval = *src;
			result = (GFC_INTEGER_8)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_8)n + 1;
		    }
		}
	      else
	        for (; n < len; n++, src += delta, msrc += mdelta)
		  {
		    if (*msrc && unlikely (*src < minval))
		      {
		        minval = *src;
			result = (GFC_INTEGER_8) 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_8_r4 (gfc_array_i8 * const restrict, 
	gfc_array_r4 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
export_proto(sminloc1_8_r4);

void
sminloc1_8_r4 (gfc_array_i8 * 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_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (mask == NULL || *mask)
    {
#ifdef HAVE_BACK_ARG
      minloc1_8_r4 (retarray, array, pdim, back);
#else
      minloc1_8_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];

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