[thirdparty/gcc.git] / libgfortran / generated / maxval_r8.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_REAL_8) && defined (HAVE_GFC_REAL_8)


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

void
maxval_r8 (gfc_array_r8 * const restrict retarray, 
	gfc_array_r8 * const restrict array, 
	const index_type * const restrict pdim)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  const GFC_REAL_8 * restrict base;
  GFC_REAL_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type len;
  index_type delta;
  index_type dim;
  int continue_loop;

  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  if (len < 0)
    len = 0;
  delta = array->dim[dim].stride;

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

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

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

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

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

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

      alloc_size = sizeof (GFC_REAL_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 (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"
			       " 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;

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

  result = -GFC_REAL_8_HUGE;
        if (len <= 0)
	  *dest = -GFC_REAL_8_HUGE;
	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.  */
	      continue_loop = 0;
	      break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              dest += dstride[n];
            }
        }
    }
}


extern void mmaxval_r8 (gfc_array_r8 * const restrict, 
	gfc_array_r8 * const restrict, const index_type * const restrict,
	gfc_array_l1 * const restrict);
export_proto(mmaxval_r8);

void
mmaxval_r8 (gfc_array_r8 * const restrict retarray, 
	gfc_array_r8 * const restrict array, 
	const index_type * const restrict pdim, 
	gfc_array_l1 * const restrict mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  index_type mstride[GFC_MAX_DIMENSIONS];
  GFC_REAL_8 * restrict dest;
  const GFC_REAL_8 * restrict base;
  const GFC_LOGICAL_1 * restrict mbase;
  int rank;
  int dim;
  index_type n;
  index_type len;
  index_type delta;
  index_type mdelta;
  int mask_kind;

  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

  len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
  if (len <= 0)
    return;

  mbase = mask->data;

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || mask_kind == 16
#endif
      )
    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
  else
    runtime_error ("Funny sized logical array");

  delta = array->dim[dim].stride;
  mdelta = mask->dim[dim].stride * mask_kind;

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

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

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

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

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

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

      alloc_size = sizeof (GFC_REAL_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 (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"
			       " 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_REAL_8 * restrict src;
      const GFC_LOGICAL_1 * restrict msrc;
      GFC_REAL_8 result;
      src = base;
      msrc = mbase;
      {

  result = -GFC_REAL_8_HUGE;
        if (len <= 0)
	  *dest = -GFC_REAL_8_HUGE;
	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_r8 (gfc_array_r8 * const restrict, 
	gfc_array_r8 * const restrict, const index_type * const restrict,
	GFC_LOGICAL_4 *);
export_proto(smaxval_r8);

void
smaxval_r8 (gfc_array_r8 * const restrict retarray, 
	gfc_array_r8 * const restrict array, 
	const index_type * const restrict pdim, 
	GFC_LOGICAL_4 * mask)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride[GFC_MAX_DIMENSIONS];
  GFC_REAL_8 * restrict dest;
  index_type rank;
  index_type n;
  index_type dim;


  if (*mask)
    {
      maxval_r8 (retarray, array, pdim);
      return;
    }
  /* Make dim zero based to avoid confusion.  */
  dim = (*pdim) - 1;
  rank = GFC_DESCRIPTOR_RANK (array) - 1;

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

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

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

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

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

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

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

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