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

/* Implementation of the MAXVAL 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>


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


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

void
maxval_i8 (gfc_array_i8 * 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_8 * 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_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"
		       " MAXVAL 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"
			       " MAXVAL 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_8 result;
      src = base;
      {

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

  if (*src > result)
    result = *src;
          }
	    *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 mmaxval_i8 (gfc_array_i8 * const restrict, 
	gfc_array_i8 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxval_i8);

void
mmaxval_i8 (gfc_array_i8 * 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_8 * 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_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 MAXVAL 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"
			       " MAXVAL 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"
			       " MAXVAL 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_8 result;
      src = base;
      msrc = mbase;
      {

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

  if (*msrc && *src > result)
    result = *src;
              }
	    *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 smaxval_i8 (gfc_array_i8 * const restrict, 
	gfc_array_i8 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxval_i8);

void
smaxval_i8 (gfc_array_i8 * 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_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


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