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

/* Implementation of the MAXLOC intrinsic
   Copyright 2002, 2007 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 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

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.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

#include "libgfortran.h"
#include <stdlib.h>
#include <assert.h>
#include <limits.h>


#if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_16)


extern void maxloc1_16_i8 (gfc_array_i16 * const restrict, 
	gfc_array_i8 * const restrict, const index_type * const restrict);
export_proto(maxloc1_16_i8);

void
maxloc1_16_i8 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i8 * 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_INTEGER_8 * restrict base;
  GFC_INTEGER_16 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

  /* Make dim zero based to avoid confusion.  */
  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_16) * 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"
		       " MAXLOC 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"
			       " MAXLOC 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_INTEGER_8 * restrict src;
      GFC_INTEGER_16 result;
      src = base;
      {

  GFC_INTEGER_8 maxval;
  maxval = (-GFC_INTEGER_8_HUGE-1);
  result = 0;
        if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta)
	      {

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


extern void mmaxloc1_16_i8 (gfc_array_i16 * const restrict, 
	gfc_array_i8 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxloc1_16_i8);

void
mmaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i8 * 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_16 * restrict dest;
  const GFC_INTEGER_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_16) * 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 MAXLOC 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"
			       " MAXLOC 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"
			       " MAXLOC 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_INTEGER_8 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_16 result;
      src = base;
      msrc = mbase;
      {

  GFC_INTEGER_8 maxval;
  maxval = (-GFC_INTEGER_8_HUGE-1);
  result = 0;
        if (len <= 0)
	  *dest = 0;
	else
	  {
	    for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	      {

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


extern void smaxloc1_16_i8 (gfc_array_i16 * const restrict, 
	gfc_array_i8 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxloc1_16_i8);

void
smaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i8 * 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_16 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


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