[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;

  /* 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_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.  */
              base = NULL;
              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 (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 rank;
  index_type n;
  index_type dstride;
  GFC_INTEGER_16 *dest;

  if (*mask)
    {
      maxloc1_16_i8 (retarray, array, pdim);
      return;
    }
    rank = GFC_DESCRIPTOR_RANK (array);
  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->data == NULL)
    {
      retarray->dim[0].lbound = 0;
      retarray->dim[0].ubound = rank-1;
      retarray->dim[0].stride = 1;
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
      retarray->offset = 0;
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
    }
  else
    {
      if (compile_options.bounds_check)
	{
	  int ret_rank;
	  index_type ret_extent;

	  ret_rank = GFC_DESCRIPTOR_RANK (retarray);
	  if (ret_rank != 1)
	    runtime_error ("rank of return array in MAXLOC intrinsic"
			   " should be 1, is %ld", (long int) ret_rank);

	  ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
	    if (ret_extent != rank)
	      runtime_error ("dimension of return array incorrect");
	}
    }
    dstride = retarray->dim[0].stride;
    dest = retarray->data;

    for (n = 0; n < rank; n++)
      dest[n * dstride] = 0 ;
}

#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;
	60
	61	/* Make dim zero based to avoid confusion. */
	62	dim = (*pdim) - 1;
	63	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	64
644cb69f FXC	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;
80ee04b9 TK	72
	73	if (extent[n] < 0)
	74	extent[n] = 0;
644cb69f FXC	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;
80ee04b9 TK	81
	82	if (extent[n] < 0)
	83	extent[n] = 0;
644cb69f FXC	84	}
	85
	86	if (retarray->data == NULL)
	87	{
80ee04b9 TK	88	size_t alloc_size;
80ee04b9 TK	89
644cb69f FXC	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
644cb69f FXC	100	retarray->offset = 0;
644cb69f FXC	101	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	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);
644cb69f FXC	115	}
	116	else
	117	{
644cb69f	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	}
644cb69f FXC	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	{
64acfd99	154	const GFC_INTEGER_8 * restrict src;
644cb69f FXC	155	GFC_INTEGER_16 result;
	156	src = base;
	157	{
	158
	159	GFC_INTEGER_8 maxval;
88116029	160	maxval = (-GFC_INTEGER_8_HUGE-1);
a4b9e93e	161	result = 0;
644cb69f FXC	162	if (len <= 0)
	163	*dest = 0;
	164	else
	165	{
	166	for (n = 0; n < len; n++, src += delta)
	167	{
	168
a4b9e93e	169	if (*src > maxval \|\| !result)
644cb69f FXC	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
5d7adf7a	189	frequently used path so probably not worth it. */
644cb69f FXC	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
64acfd99 JB	210	extern void mmaxloc1_16_i8 (gfc_array_i16 * const restrict,
64acfd99 JB	211	gfc_array_i8 * const restrict, const index_type * const restrict,
28dc6b33	212	gfc_array_l1 * const restrict);
644cb69f FXC	213	export_proto(mmaxloc1_16_i8);
	214
	215	void
64acfd99 JB	216	mmaxloc1_16_i8 (gfc_array_i16 * const restrict retarray,
	217	gfc_array_i8 * const restrict array,
	218	const index_type * const restrict pdim,
28dc6b33	219	gfc_array_l1 * const restrict mask)
644cb69f FXC	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];
64acfd99 JB	226	GFC_INTEGER_16 * restrict dest;
64acfd99 JB	227	const GFC_INTEGER_8 * restrict base;
28dc6b33	228	const GFC_LOGICAL_1 * restrict mbase;
644cb69f FXC	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;
644cb69f FXC	236
	237	dim = (*pdim) - 1;
	238	rank = GFC_DESCRIPTOR_RANK (array) - 1;
	239
644cb69f FXC	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
644cb69f	257	delta = array->dim[dim].stride;
28dc6b33	258	mdelta = mask->dim[dim].stride * mask_kind;
644cb69f FXC	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;
644cb69f	264	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
80ee04b9 TK	265
	266	if (extent[n] < 0)
	267	extent[n] = 0;
	268
644cb69f FXC	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;
644cb69f FXC	274	extent[n] =
644cb69f FXC	275	array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
80ee04b9 TK	276
	277	if (extent[n] < 0)
	278	extent[n] = 0;
644cb69f FXC	279	}
	280
	281	if (retarray->data == NULL)
	282	{
80ee04b9 TK	283	size_t alloc_size;
80ee04b9 TK	284
644cb69f FXC	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
80ee04b9 TK	295	alloc_size = sizeof (GFC_INTEGER_16) * retarray->dim[rank-1].stride
	296	* extent[rank-1];
	297
644cb69f FXC	298	retarray->offset = 0;
644cb69f FXC	299	retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) \| rank;
80ee04b9 TK	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
644cb69f FXC	311	}
	312	else
	313	{
644cb69f	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	}
644cb69f FXC	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;
644cb69f FXC	356
	357	while (base)
	358	{
64acfd99	359	const GFC_INTEGER_8 * restrict src;
28dc6b33	360	const GFC_LOGICAL_1 * restrict msrc;
644cb69f FXC	361	GFC_INTEGER_16 result;
	362	src = base;
	363	msrc = mbase;
	364	{
	365
	366	GFC_INTEGER_8 maxval;
88116029	367	maxval = (-GFC_INTEGER_8_HUGE-1);
a4b9e93e	368	result = 0;
644cb69f FXC	369	if (len <= 0)
	370	*dest = 0;
	371	else
	372	{
	373	for (n = 0; n < len; n++, src += delta, msrc += mdelta)
	374	{
	375
a4b9e93e	376	if (msrc && (src > maxval \|\| !result))
644cb69f FXC	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
5d7adf7a	397	frequently used path so probably not worth it. */
644cb69f FXC	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
97a62038 TK	419
	420	extern void smaxloc1_16_i8 (gfc_array_i16 * const restrict,
	421	gfc_array_i8 * const restrict, const index_type * const restrict,
	422	GFC_LOGICAL_4 *);
	423	export_proto(smaxloc1_16_i8);
	424
	425	void
	426	smaxloc1_16_i8 (gfc_array_i16 * const restrict retarray,
	427	gfc_array_i8 * const restrict array,
	428	const index_type * const restrict pdim,
	429	GFC_LOGICAL_4 * mask)
	430	{
	431	index_type rank;
	432	index_type n;
	433	index_type dstride;
	434	GFC_INTEGER_16 *dest;
	435
	436	if (*mask)
	437	{
	438	maxloc1_16_i8 (retarray, array, pdim);
	439	return;
	440	}
	441	rank = GFC_DESCRIPTOR_RANK (array);
	442	if (rank <= 0)
	443	runtime_error ("Rank of array needs to be > 0");
	444
	445	if (retarray->data == NULL)
	446	{
	447	retarray->dim[0].lbound = 0;
	448	retarray->dim[0].ubound = rank-1;
	449	retarray->dim[0].stride = 1;
	450	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	451	retarray->offset = 0;
	452	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank);
	453	}
	454	else
	455	{
fd6590f8 TK	456	if (compile_options.bounds_check)
	457	{
	458	int ret_rank;
	459	index_type ret_extent;
97a62038	460
fd6590f8 TK	461	ret_rank = GFC_DESCRIPTOR_RANK (retarray);
	462	if (ret_rank != 1)
	463	runtime_error ("rank of return array in MAXLOC intrinsic"
ccacefc7	464	" should be 1, is %ld", (long int) ret_rank);
97a62038	465
fd6590f8 TK	466	ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
	467	if (ret_extent != rank)
	468	runtime_error ("dimension of return array incorrect");
	469	}
	470	}
97a62038 TK	471	dstride = retarray->dim[0].stride;
	472	dest = retarray->data;
	473
	474	for (n = 0; n < rank; n++)
	475	dest[n * dstride] = 0 ;
	476	}
	477
644cb69f	478	#endif