[thirdparty/gcc.git] / libgfortran / generated / minloc1_4_r16.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_16) && defined (HAVE_GFC_INTEGER_4)


extern void minloc1_4_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict);
export_proto(minloc1_4_r16);

void
minloc1_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * 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_16 * restrict base;
  GFC_INTEGER_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  len = GFC_DESCRIPTOR_EXTENT(array,dim);
  if (len < 0)
    len = 0;
  delta = GFC_DESCRIPTOR_STRIDE(array,dim);

  for (n = 0; n < dim; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);

      if (extent[n] < 0)
	extent[n] = 0;
    }

  if (retarray->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_4) * 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);
      if (extent[n] <= 0)
        len = 0;
    }

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

  continue_loop = 1;
  while (continue_loop)
    {
      const GFC_REAL_16 * restrict src;
      GFC_INTEGER_4 result;
      src = base;
      {

  GFC_REAL_16 minval;
  minval = GFC_REAL_16_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_4)n + 1;
    }
          }
	    *dest = result;
	  }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          count[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          base -= sstride[n] * extent[n];
          dest -= dstride[n] * extent[n];
          n++;
          if (n == rank)
            {
              /* Break out of the look.  */
	      continue_loop = 0;
	      break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              dest += dstride[n];
            }
        }
    }
}


extern void mminloc1_4_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mminloc1_4_r16);

void
mminloc1_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_INTEGER_4 * restrict dest;
  const GFC_REAL_16 * 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_4) * 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))
	{
	  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++)
            {
              index_type mask_extent, array_extent;

	      array_extent = GFC_DESCRIPTOR_EXTENT(array,n);
	      mask_extent = GFC_DESCRIPTOR_EXTENT(mask,n);
	      if (array_extent != mask_extent)
		runtime_error ("Incorrect extent in MASK argument of"
			       " MINLOC intrinsic in dimension %ld:"
			       " is %ld, should be %ld", (long int) n + 1,
			       (long int) mask_extent, (long int) array_extent);
	    }
	}
    }

  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_16 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_4 result;
      src = base;
      msrc = mbase;
      {

  GFC_REAL_16 minval;
  minval = GFC_REAL_16_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_4)n + 1;
    }
              }
	    *dest = result;
	  }
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[0];
      dest += dstride[0];
      n = 0;
      while (count[n] == extent[n])
        {
          /* When we get to the end of a dimension, reset it and increment
             the next dimension.  */
          count[n] = 0;
          /* We could precalculate these products, but this is a less
             frequently used path so probably not worth it.  */
          base -= sstride[n] * extent[n];
          mbase -= mstride[n] * extent[n];
          dest -= dstride[n] * extent[n];
          n++;
          if (n == rank)
            {
              /* Break out of the look.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              mbase += mstride[n];
              dest += dstride[n];
            }
        }
    }
}


extern void sminloc1_4_r16 (gfc_array_i4 * const restrict, 
	gfc_array_r16 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sminloc1_4_r16);

void
sminloc1_4_r16 (gfc_array_i4 * const restrict retarray, 
	gfc_array_r16 * 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_4 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


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