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

/* Implementation of the MINLOC intrinsic
   Copyright 2002, 2007, 2009 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

This file is part of the GNU Fortran 95 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_10) && defined (HAVE_GFC_INTEGER_8)


extern void minloc1_8_r10 (gfc_array_i8 * const restrict, 
	gfc_array_r10 * const restrict, const index_type * const restrict);
export_proto(minloc1_8_r10);

void
minloc1_8_r10 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r10 * 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_10 * 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.  */
  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_8) * 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))
	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)
        len = 0;
    }

  base = array->data;
  dest = retarray->data;

  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_REAL_10 * restrict src;
      GFC_INTEGER_8 result;
      src = base;
      {

  GFC_REAL_10 minval;
  minval = GFC_REAL_10_HUGE;
  result = 0;
        if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

  if (*src < minval || !result)
    {
      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 look.  */
	      continue_loop = 0;
	      break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              dest += dstride[n];
            }
        }
    }
}


extern void mminloc1_8_r10 (gfc_array_i8 * const restrict, 
	gfc_array_r10 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mminloc1_8_r10);

void
mminloc1_8_r10 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r10 * 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_8 * restrict dest;
  const GFC_REAL_10 * 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_8) * 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_10 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_8 result;
      src = base;
      msrc = mbase;
      {

  GFC_REAL_10 minval;
  minval = GFC_REAL_10_HUGE;
  result = 0;
        if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

  if (*msrc && (*src < minval || !result))
    {
      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 look.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              mbase += mstride[n];
              dest += dstride[n];
            }
        }
    }
}


extern void sminloc1_8_r10 (gfc_array_i8 * const restrict, 
	gfc_array_r10 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sminloc1_8_r10);

void
sminloc1_8_r10 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r10 * 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 sstride[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)
    {
      minloc1_8_r10 (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++)
    {
      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_8) * 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
748086b7	2	Copyright 2002, 2007, 2009 Free Software Foundation, Inc.
644cb69f FXC	3	Contributed by Paul Brook <paul@nowt.org>
	4
	5	This file is part of the GNU Fortran 95 runtime library (libgfortran).
	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_10) && defined (HAVE_GFC_INTEGER_8)
	33
	34
64acfd99 JB	35	extern void minloc1_8_r10 (gfc_array_i8 * const restrict,
64acfd99 JB	36	gfc_array_r10 * const restrict, const index_type * const restrict);
644cb69f FXC	37	export_proto(minloc1_8_r10);
	38
	39	void
64acfd99 JB	40	minloc1_8_r10 (gfc_array_i8 * const restrict retarray,
	41	gfc_array_r10 * 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_10 * restrict base;
64acfd99 JB	49	GFC_INTEGER_8 * 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 FXC	87	for (n = 0; n < rank; n++)
644cb69f FXC	88	{
644cb69f	89	if (n == 0)
dfb55fdc	90	str = 1;
644cb69f	91	else
dfb55fdc TK	92	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	93
	94	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	95
644cb69f FXC	96	}
644cb69f FXC	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_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
80ee04b9 TK	102	* extent[rank-1];
	103
	104	if (alloc_size == 0)
	105	{
	106	/* Make sure we have a zero-sized array. */
dfb55fdc	107	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9	108	return;
dfb55fdc	109
80ee04b9 TK	110	}
	111	else
	112	retarray->data = internal_malloc_size (alloc_size);
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 FXC	131	if (extent[n] <= 0)
	132	len = 0;
	133	}
	134
	135	base = array->data;
	136	dest = retarray->data;
	137
da96f5ab TK	138	continue_loop = 1;
da96f5ab TK	139	while (continue_loop)
644cb69f	140	{
64acfd99	141	const GFC_REAL_10 * restrict src;
644cb69f FXC	142	GFC_INTEGER_8 result;
	143	src = base;
	144	{
	145
	146	GFC_REAL_10 minval;
	147	minval = GFC_REAL_10_HUGE;
a4b9e93e	148	result = 0;
644cb69f FXC	149	if (len <= 0)
	150	*dest = 0;
	151	else
	152	{
	153	for (n = 0; n < len; n++, src += delta)
	154	{
	155
a4b9e93e	156	if (*src < minval \|\| !result)
644cb69f FXC	157	{
	158	minval = *src;
	159	result = (GFC_INTEGER_8)n + 1;
	160	}
	161	}
	162	*dest = result;
	163	}
	164	}
	165	/* Advance to the next element. */
	166	count[0]++;
	167	base += sstride[0];
	168	dest += dstride[0];
	169	n = 0;
	170	while (count[n] == extent[n])
	171	{
	172	/* When we get to the end of a dimension, reset it and increment
	173	the next dimension. */
	174	count[n] = 0;
	175	/* We could precalculate these products, but this is a less
5d7adf7a	176	frequently used path so probably not worth it. */
644cb69f FXC	177	base -= sstride[n] * extent[n];
	178	dest -= dstride[n] * extent[n];
	179	n++;
	180	if (n == rank)
	181	{
	182	/* Break out of the look. */
da96f5ab TK	183	continue_loop = 0;
da96f5ab TK	184	break;
644cb69f FXC	185	}
	186	else
	187	{
	188	count[n]++;
	189	base += sstride[n];
	190	dest += dstride[n];
	191	}
	192	}
	193	}
	194	}
	195
	196
64acfd99 JB	197	extern void mminloc1_8_r10 (gfc_array_i8 * const restrict,
64acfd99 JB	198	gfc_array_r10 * const restrict, const index_type * const restrict,
28dc6b33	199	gfc_array_l1 * const restrict);
644cb69f FXC	200	export_proto(mminloc1_8_r10);
	201
	202	void
64acfd99 JB	203	mminloc1_8_r10 (gfc_array_i8 * const restrict retarray,
	204	gfc_array_r10 * const restrict array,
	205	const index_type * const restrict pdim,
28dc6b33	206	gfc_array_l1 * const restrict mask)
644cb69f FXC	207	{
	208	index_type count[GFC_MAX_DIMENSIONS];
	209	index_type extent[GFC_MAX_DIMENSIONS];
	210	index_type sstride[GFC_MAX_DIMENSIONS];
	211	index_type dstride[GFC_MAX_DIMENSIONS];
	212	index_type mstride[GFC_MAX_DIMENSIONS];
64acfd99 JB	213	GFC_INTEGER_8 * restrict dest;
64acfd99 JB	214	const GFC_REAL_10 * restrict base;
28dc6b33	215	const GFC_LOGICAL_1 * restrict mbase;
644cb69f FXC	216	int rank;
	217	int dim;
	218	index_type n;
	219	index_type len;
	220	index_type delta;
	221	index_type mdelta;
28dc6b33	222	int mask_kind;
644cb69f FXC	223
	224	dim = (*pdim) - 1;
	225	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	226
dfb55fdc	227	len = GFC_DESCRIPTOR_EXTENT(array,dim);
644cb69f FXC	228	if (len <= 0)
644cb69f FXC	229	return;
28dc6b33 TK	230
	231	mbase = mask->data;
	232
	233	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	234
	235	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	236	#ifdef HAVE_GFC_LOGICAL_16
	237	\|\| mask_kind == 16
	238	#endif
	239	)
	240	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	241	else
	242	runtime_error ("Funny sized logical array");
	243
dfb55fdc TK	244	delta = GFC_DESCRIPTOR_STRIDE(array,dim);
dfb55fdc TK	245	mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
644cb69f FXC	246
	247	for (n = 0; n < dim; n++)
	248	{
dfb55fdc TK	249	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
	250	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
	251	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
80ee04b9 TK	252
	253	if (extent[n] < 0)
	254	extent[n] = 0;
	255
644cb69f FXC	256	}
	257	for (n = dim; n < rank; n++)
	258	{
dfb55fdc TK	259	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
	260	mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
	261	extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
80ee04b9 TK	262
	263	if (extent[n] < 0)
	264	extent[n] = 0;
644cb69f FXC	265	}
	266
	267	if (retarray->data == NULL)
	268	{
dfb55fdc	269	size_t alloc_size, str;
80ee04b9	270
644cb69f FXC	271	for (n = 0; n < rank; n++)
644cb69f FXC	272	{
644cb69f	273	if (n == 0)
dfb55fdc	274	str = 1;
644cb69f	275	else
dfb55fdc TK	276	str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	277
	278	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	279
644cb69f FXC	280	}
644cb69f FXC	281
dfb55fdc	282	alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
80ee04b9 TK	283	* extent[rank-1];
80ee04b9 TK	284
644cb69f FXC	285	retarray->offset = 0;
644cb69f FXC	286	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	287
	288	if (alloc_size == 0)
	289	{
	290	/* Make sure we have a zero-sized array. */
dfb55fdc	291	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
80ee04b9 TK	292	return;
	293	}
	294	else
	295	retarray->data = internal_malloc_size (alloc_size);
	296
644cb69f FXC	297	}
	298	else
	299	{
644cb69f	300	if (rank != GFC_DESCRIPTOR_RANK (retarray))
fd6590f8 TK	301	runtime_error ("rank of return array incorrect in MINLOC intrinsic");
fd6590f8 TK	302
9731c4a3	303	if (unlikely (compile_options.bounds_check))
fd6590f8	304	{
16bff921 TK	305	bounds_ifunction_return ((array_t *) retarray, extent,
	306	"return value", "MINLOC");
	307	bounds_equal_extents ((array_t ) mask, (array_t ) array,
	308	"MASK argument", "MINLOC");
fd6590f8	309	}
644cb69f FXC	310	}
	311
	312	for (n = 0; n < rank; n++)
	313	{
	314	count[n] = 0;
dfb55fdc	315	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
644cb69f FXC	316	if (extent[n] <= 0)
	317	return;
	318	}
	319
	320	dest = retarray->data;
	321	base = array->data;
644cb69f FXC	322
	323	while (base)
	324	{
64acfd99	325	const GFC_REAL_10 * restrict src;
28dc6b33	326	const GFC_LOGICAL_1 * restrict msrc;
644cb69f FXC	327	GFC_INTEGER_8 result;
	328	src = base;
	329	msrc = mbase;
	330	{
	331
	332	GFC_REAL_10 minval;
	333	minval = GFC_REAL_10_HUGE;
a4b9e93e	334	result = 0;
644cb69f FXC	335	if (len <= 0)
	336	*dest = 0;
	337	else
	338	{
	339	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	340	{
	341
a4b9e93e	342	if (msrc && (src < minval \|\| !result))
644cb69f FXC	343	{
	344	minval = *src;
	345	result = (GFC_INTEGER_8)n + 1;
	346	}
	347	}
	348	*dest = result;
	349	}
	350	}
	351	/* Advance to the next element. */
	352	count[0]++;
	353	base += sstride[0];
	354	mbase += mstride[0];
	355	dest += dstride[0];
	356	n = 0;
	357	while (count[n] == extent[n])
	358	{
	359	/* When we get to the end of a dimension, reset it and increment
	360	the next dimension. */
	361	count[n] = 0;
	362	/* We could precalculate these products, but this is a less
5d7adf7a	363	frequently used path so probably not worth it. */
644cb69f FXC	364	base -= sstride[n] * extent[n];
	365	mbase -= mstride[n] * extent[n];
	366	dest -= dstride[n] * extent[n];
	367	n++;
	368	if (n == rank)
	369	{
	370	/* Break out of the look. */
	371	base = NULL;
	372	break;
	373	}
	374	else
	375	{
	376	count[n]++;
	377	base += sstride[n];
	378	mbase += mstride[n];
	379	dest += dstride[n];
	380	}
	381	}
	382	}
	383	}
	384
97a62038 TK	385
	386	extern void sminloc1_8_r10 (gfc_array_i8 * const restrict,
	387	gfc_array_r10 * const restrict, const index_type * const restrict,
	388	GFC_LOGICAL_4 *);
	389	export_proto(sminloc1_8_r10);
	390
	391	void
	392	sminloc1_8_r10 (gfc_array_i8 * const restrict retarray,
	393	gfc_array_r10 * const restrict array,
	394	const index_type * const restrict pdim,
	395	GFC_LOGICAL_4 * mask)
	396	{
802367d7 TK	397	index_type count[GFC_MAX_DIMENSIONS];
	398	index_type extent[GFC_MAX_DIMENSIONS];
	399	index_type sstride[GFC_MAX_DIMENSIONS];
	400	index_type dstride[GFC_MAX_DIMENSIONS];
	401	GFC_INTEGER_8 * restrict dest;
97a62038 TK	402	index_type rank;
97a62038 TK	403	index_type n;
802367d7 TK	404	index_type dim;
802367d7 TK	405
97a62038 TK	406
	407	if (*mask)
	408	{
	409	minloc1_8_r10 (retarray, array, pdim);
	410	return;
	411	}
802367d7 TK	412	/* Make dim zero based to avoid confusion. */
	413	dim = (*pdim) - 1;
	414	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	415
	416	for (n = 0; n < dim; n++)
	417	{
dfb55fdc TK	418	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
dfb55fdc TK	419	extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
802367d7 TK	420
	421	if (extent[n] <= 0)
	422	extent[n] = 0;
	423	}
	424
	425	for (n = dim; n < rank; n++)
	426	{
dfb55fdc	427	sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
802367d7	428	extent[n] =
dfb55fdc	429	GFC_DESCRIPTOR_EXTENT(array,n + 1);
802367d7 TK	430
	431	if (extent[n] <= 0)
	432	extent[n] = 0;
	433	}
97a62038 TK	434
	435	if (retarray->data == NULL)
	436	{
dfb55fdc	437	size_t alloc_size, str;
802367d7 TK	438
	439	for (n = 0; n < rank; n++)
	440	{
802367d7	441	if (n == 0)
dfb55fdc	442	str = 1;
802367d7	443	else
dfb55fdc TK	444	str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
	445
	446	GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
	447
802367d7 TK	448	}
802367d7 TK	449
97a62038	450	retarray->offset = 0;
802367d7 TK	451	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
802367d7 TK	452
dfb55fdc	453	alloc_size = sizeof (GFC_INTEGER_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
802367d7 TK	454	* extent[rank-1];
	455
	456	if (alloc_size == 0)
	457	{
	458	/* Make sure we have a zero-sized array. */
dfb55fdc	459	GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
802367d7 TK	460	return;
	461	}
	462	else
	463	retarray->data = internal_malloc_size (alloc_size);
97a62038 TK	464	}
	465	else
	466	{
802367d7 TK	467	if (rank != GFC_DESCRIPTOR_RANK (retarray))
	468	runtime_error ("rank of return array incorrect in"
	469	" MINLOC intrinsic: is %ld, should be %ld",
	470	(long int) (GFC_DESCRIPTOR_RANK (retarray)),
	471	(long int) rank);
	472
9731c4a3	473	if (unlikely (compile_options.bounds_check))
fd6590f8	474	{
802367d7 TK	475	for (n=0; n < rank; n++)
	476	{
	477	index_type ret_extent;
97a62038	478
dfb55fdc	479	ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
802367d7 TK	480	if (extent[n] != ret_extent)
	481	runtime_error ("Incorrect extent in return value of"
	482	" MINLOC intrinsic in dimension %ld:"
	483	" is %ld, should be %ld", (long int) n + 1,
	484	(long int) ret_extent, (long int) extent[n]);
	485	}
fd6590f8 TK	486	}
fd6590f8 TK	487	}
97a62038	488
802367d7 TK	489	for (n = 0; n < rank; n++)
	490	{
	491	count[n] = 0;
dfb55fdc	492	dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
802367d7 TK	493	}
	494
	495	dest = retarray->data;
	496
	497	while(1)
	498	{
	499	*dest = 0;
	500	count[0]++;
	501	dest += dstride[0];
	502	n = 0;
	503	while (count[n] == extent[n])
	504	{
	505	/* When we get to the end of a dimension, reset it and increment
	506	the next dimension. */
	507	count[n] = 0;
	508	/* We could precalculate these products, but this is a less
	509	frequently used path so probably not worth it. */
	510	dest -= dstride[n] * extent[n];
	511	n++;
	512	if (n == rank)
	513	return;
	514	else
	515	{
	516	count[n]++;
	517	dest += dstride[n];
	518	}
	519	}
	520	}
97a62038 TK	521	}
97a62038 TK	522
644cb69f	523	#endif