[thirdparty/gcc.git] / libgfortran / generated / maxloc1_16_i2.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_2) && defined (HAVE_GFC_INTEGER_16)


extern void maxloc1_16_i2 (gfc_array_i16 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict);
export_proto(maxloc1_16_i2);

void
maxloc1_16_i2 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i2 * 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_2 * restrict base;
  GFC_INTEGER_16 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;

  /* 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;
  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 (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;

  while (base)
    {
      const GFC_INTEGER_2 * restrict src;
      GFC_INTEGER_16 result;
      src = base;
      {

  GFC_INTEGER_2 maxval;
  maxval = (-GFC_INTEGER_2_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.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              dest += dstride[n];
            }
        }
    }
}


extern void mmaxloc1_16_i2 (gfc_array_i16 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxloc1_16_i2);

void
mmaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, 
	gfc_array_i2 * 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_2 * 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 (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_2 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_INTEGER_16 result;
      src = base;
      msrc = mbase;
      {

  GFC_INTEGER_2 maxval;
  maxval = (-GFC_INTEGER_2_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_i2 (gfc_array_i16 * const restrict, 
	gfc_array_i2 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxloc1_16_i2);

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