[thirdparty/gcc.git] / libgfortran / generated / minloc1_8_r8.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_8) && defined (HAVE_GFC_INTEGER_8)


extern void minloc1_8_r8 (gfc_array_i8 * const restrict, 
	gfc_array_r8 * const restrict, const index_type * const restrict);
export_proto(minloc1_8_r8);

void
minloc1_8_r8 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r8 * 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_8 * 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 = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  if (len < 0)
    len = 0;
  delta = array->dim[dim].stride;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

      if (extent[n] < 0)
	extent[n] = 0;
    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

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

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

      alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
    		   * extent[rank-1];

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -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 = retarray->dim[n].ubound + 1
		- retarray->dim[n].lbound;
	      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] = retarray->dim[n].stride;
      if (extent[n] <= 0)
        len = 0;
    }

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

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

  GFC_REAL_8 minval;
  minval = GFC_REAL_8_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_r8 (gfc_array_i8 * const restrict, 
	gfc_array_r8 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mminloc1_8_r8);

void
mminloc1_8_r8 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r8 * 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_8 * 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 = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  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 = array->dim[dim].stride;
  mdelta = mask->dim[dim].stride * mask_kind;

  for (n = 0; n < dim; n++)
    {
      sstride[n] = array->dim[n].stride;
      mstride[n] = mask->dim[n].stride * mask_kind;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

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

    }
  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      mstride[n] = mask->dim[n + 1].stride * mask_kind;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

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

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

      alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
    		   * 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.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -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 = retarray->dim[n].ubound + 1
		- retarray->dim[n].lbound;
	      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 = array->dim[n].ubound + 1 - array->dim[n].lbound;
	      mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
	      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] = retarray->dim[n].stride;
      if (extent[n] <= 0)
        return;
    }

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

  while (base)
    {
      const GFC_REAL_8 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_8 result;
      src = base;
      msrc = mbase;
      {

  GFC_REAL_8 minval;
  minval = GFC_REAL_8_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_r8 (gfc_array_i8 * const restrict, 
	gfc_array_r8 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(sminloc1_8_r8);

void
sminloc1_8_r8 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r8 * 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_r8 (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] = array->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;

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

  for (n = dim; n < rank; n++)
    {
      sstride[n] = array->dim[n + 1].stride;
      extent[n] =
        array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;

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

  if (retarray->data == NULL)
    {
      size_t alloc_size;

      for (n = 0; n < rank; n++)
        {
          retarray->dim[n].lbound = 0;
          retarray->dim[n].ubound = extent[n]-1;
          if (n == 0)
            retarray->dim[n].stride = 1;
          else
            retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
        }

      retarray->offset = 0;
      retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;

      alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
    		   * extent[rank-1];

      if (alloc_size == 0)
	{
	  /* Make sure we have a zero-sized array.  */
	  retarray->dim[0].lbound = 0;
	  retarray->dim[0].ubound = -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 = retarray->dim[n].ubound + 1
		- retarray->dim[n].lbound;
	      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] = retarray->dim[n].stride;
    }

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