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

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

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.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */

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


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


extern void maxloc0_8_r10 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r10 * const restrict array);
export_proto(maxloc0_8_r10);

void
maxloc0_8_r10 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r10 * const restrict array)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type dstride;
  const GFC_REAL_10 *base;
  GFC_INTEGER_8 * restrict dest;
  index_type rank;
  index_type n;

  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_8) * rank);
    }
  else
    {
      if (unlikely (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 ("Incorrect extent in return value of"
			   " MAXLOC intrnisic: is %ld, should be %ld",
			   (long int) ret_extent, (long int) rank);
	}
    }

  dstride = retarray->dim[0].stride;
  dest = retarray->data;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = array->dim[n].stride;
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
      count[n] = 0;
      if (extent[n] <= 0)
	{
	  /* Set the return value.  */
	  for (n = 0; n < rank; n++)
	    dest[n * dstride] = 0;
	  return;
	}
    }

  base = array->data;

  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;
  {

  GFC_REAL_10 maxval;

  maxval = -GFC_REAL_10_HUGE;

  while (base)
    {
      {
        /* Implementation start.  */

  if (*base > maxval || !dest[0])
    {
      maxval = *base;
      for (n = 0; n < rank; n++)
        dest[n * dstride] = count[n] + 1;
    }
        /* Implementation end.  */
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[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];
          n++;
          if (n == rank)
            {
              /* Break out of the loop.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
            }
        }
    }
  }
}


extern void mmaxloc0_8_r10 (gfc_array_i8 * const restrict, 
	gfc_array_r10 * const restrict, gfc_array_l1 * const restrict);
export_proto(mmaxloc0_8_r10);

void
mmaxloc0_8_r10 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r10 * const restrict array,
	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 mstride[GFC_MAX_DIMENSIONS];
  index_type dstride;
  GFC_INTEGER_8 *dest;
  const GFC_REAL_10 *base;
  GFC_LOGICAL_1 *mbase;
  int rank;
  index_type n;
  int mask_kind;

  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_8) * rank);
    }
  else
    {
      if (unlikely (compile_options.bounds_check))
	{
	  int ret_rank, mask_rank;
	  index_type ret_extent;
	  int n;
	  index_type array_extent, mask_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 ("Incorrect extent in return value of"
			   " MAXLOC intrnisic: is %ld, should be %ld",
			   (long int) ret_extent, (long int) rank);
	
	  mask_rank = GFC_DESCRIPTOR_RANK (mask);
	  if (rank != mask_rank)
	    runtime_error ("rank of MASK argument in MAXLOC intrnisic"
	                   "should be %ld, is %ld", (long int) rank,
			   (long int) mask_rank);

	  for (n=0; n<rank; n++)
	    {
	      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);
	    }
	}
    }

  mask_kind = GFC_DESCRIPTOR_SIZE (mask);

  mbase = mask->data;

  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");

  dstride = retarray->dim[0].stride;
  dest = retarray->data;
  for (n = 0; n < rank; 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;
      count[n] = 0;
      if (extent[n] <= 0)
	{
	  /* Set the return value.  */
	  for (n = 0; n < rank; n++)
	    dest[n * dstride] = 0;
	  return;
	}
    }

  base = array->data;

  /* Initialize the return value.  */
  for (n = 0; n < rank; n++)
    dest[n * dstride] = 0;
  {

  GFC_REAL_10 maxval;

  maxval = -GFC_REAL_10_HUGE;

  while (base)
    {
      {
        /* Implementation start.  */

  if (*mbase && (*base > maxval || !dest[0]))
    {
      maxval = *base;
      for (n = 0; n < rank; n++)
        dest[n * dstride] = count[n] + 1;
    }
        /* Implementation end.  */
      }
      /* Advance to the next element.  */
      count[0]++;
      base += sstride[0];
      mbase += mstride[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];
          n++;
          if (n == rank)
            {
              /* Break out of the loop.  */
              base = NULL;
              break;
            }
          else
            {
              count[n]++;
              base += sstride[n];
              mbase += mstride[n];
            }
        }
    }
  }
}


extern void smaxloc0_8_r10 (gfc_array_i8 * const restrict, 
	gfc_array_r10 * const restrict, GFC_LOGICAL_4 *);
export_proto(smaxloc0_8_r10);

void
smaxloc0_8_r10 (gfc_array_i8 * const restrict retarray, 
	gfc_array_r10 * const restrict array,
	GFC_LOGICAL_4 * mask)
{
  index_type rank;
  index_type dstride;
  index_type n;
  GFC_INTEGER_8 *dest;

  if (*mask)
    {
      maxloc0_8_r10 (retarray, array);
      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_8) * rank);
    }
  else
    {
      if (unlikely (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
748086b7	2	Copyright 2002, 2007, 2009 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
748086b7	10	version 3 of the License, or (at your option) any later version.
644cb69f FXC	11
	12	Libgfortran is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
	16
748086b7 JJ	17	Under Section 7 of GPL version 3, you are granted additional
	18	permissions described in the GCC Runtime Library Exception, version
	19	3.1, as published by the Free Software Foundation.
	20
	21	You should have received a copy of the GNU General Public License and
	22	a copy of the GCC Runtime Library Exception along with this program;
	23	see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
	24	<http://www.gnu.org/licenses/>. */
644cb69f	25
36ae8a61	26	#include "libgfortran.h"
644cb69f FXC	27	#include <stdlib.h>
644cb69f FXC	28	#include <assert.h>
644cb69f	29	#include <limits.h>
644cb69f FXC	30
	31
	32	#if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_INTEGER_8)
	33
	34
64acfd99 JB	35	extern void maxloc0_8_r10 (gfc_array_i8 * const restrict retarray,
64acfd99 JB	36	gfc_array_r10 * const restrict array);
644cb69f FXC	37	export_proto(maxloc0_8_r10);
	38
	39	void
64acfd99 JB	40	maxloc0_8_r10 (gfc_array_i8 * const restrict retarray,
64acfd99 JB	41	gfc_array_r10 * const restrict array)
644cb69f FXC	42	{
	43	index_type count[GFC_MAX_DIMENSIONS];
	44	index_type extent[GFC_MAX_DIMENSIONS];
	45	index_type sstride[GFC_MAX_DIMENSIONS];
	46	index_type dstride;
64acfd99	47	const GFC_REAL_10 *base;
5863aacf	48	GFC_INTEGER_8 * restrict dest;
644cb69f FXC	49	index_type rank;
	50	index_type n;
	51
	52	rank = GFC_DESCRIPTOR_RANK (array);
	53	if (rank <= 0)
	54	runtime_error ("Rank of array needs to be > 0");
	55
	56	if (retarray->data == NULL)
	57	{
	58	retarray->dim[0].lbound = 0;
	59	retarray->dim[0].ubound = rank-1;
	60	retarray->dim[0].stride = 1;
	61	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	62	retarray->offset = 0;
	63	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank);
	64	}
	65	else
	66	{
9731c4a3	67	if (unlikely (compile_options.bounds_check))
fd6590f8 TK	68	{
	69	int ret_rank;
	70	index_type ret_extent;
	71
	72	ret_rank = GFC_DESCRIPTOR_RANK (retarray);
	73	if (ret_rank != 1)
	74	runtime_error ("rank of return array in MAXLOC intrinsic"
ccacefc7	75	" should be 1, is %ld", (long int) ret_rank);
fd6590f8 TK	76
	77	ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
	78	if (ret_extent != rank)
	79	runtime_error ("Incorrect extent in return value of"
ccacefc7 TK	80	" MAXLOC intrnisic: is %ld, should be %ld",
ccacefc7 TK	81	(long int) ret_extent, (long int) rank);
fd6590f8	82	}
644cb69f FXC	83	}
644cb69f FXC	84
644cb69f FXC	85	dstride = retarray->dim[0].stride;
	86	dest = retarray->data;
	87	for (n = 0; n < rank; n++)
	88	{
	89	sstride[n] = array->dim[n].stride;
	90	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
	91	count[n] = 0;
	92	if (extent[n] <= 0)
	93	{
	94	/* Set the return value. */
	95	for (n = 0; n < rank; n++)
	96	dest[n * dstride] = 0;
	97	return;
	98	}
	99	}
	100
	101	base = array->data;
	102
	103	/* Initialize the return value. */
	104	for (n = 0; n < rank; n++)
a4b9e93e	105	dest[n * dstride] = 0;
644cb69f FXC	106	{
	107
	108	GFC_REAL_10 maxval;
	109
	110	maxval = -GFC_REAL_10_HUGE;
	111
	112	while (base)
	113	{
	114	{
	115	/* Implementation start. */
	116
a4b9e93e	117	if (*base > maxval \|\| !dest[0])
644cb69f FXC	118	{
	119	maxval = *base;
	120	for (n = 0; n < rank; n++)
	121	dest[n * dstride] = count[n] + 1;
	122	}
	123	/* Implementation end. */
	124	}
	125	/* Advance to the next element. */
	126	count[0]++;
	127	base += sstride[0];
	128	n = 0;
	129	while (count[n] == extent[n])
	130	{
	131	/* When we get to the end of a dimension, reset it and increment
	132	the next dimension. */
	133	count[n] = 0;
	134	/* We could precalculate these products, but this is a less
5d7adf7a	135	frequently used path so probably not worth it. */
644cb69f FXC	136	base -= sstride[n] * extent[n];
	137	n++;
	138	if (n == rank)
	139	{
	140	/* Break out of the loop. */
	141	base = NULL;
	142	break;
	143	}
	144	else
	145	{
	146	count[n]++;
	147	base += sstride[n];
	148	}
	149	}
	150	}
	151	}
	152	}
	153
	154
64acfd99	155	extern void mmaxloc0_8_r10 (gfc_array_i8 * const restrict,
28dc6b33	156	gfc_array_r10 * const restrict, gfc_array_l1 * const restrict);
644cb69f FXC	157	export_proto(mmaxloc0_8_r10);
	158
	159	void
64acfd99 JB	160	mmaxloc0_8_r10 (gfc_array_i8 * const restrict retarray,
64acfd99 JB	161	gfc_array_r10 * const restrict array,
28dc6b33	162	gfc_array_l1 * const restrict mask)
644cb69f FXC	163	{
	164	index_type count[GFC_MAX_DIMENSIONS];
	165	index_type extent[GFC_MAX_DIMENSIONS];
	166	index_type sstride[GFC_MAX_DIMENSIONS];
	167	index_type mstride[GFC_MAX_DIMENSIONS];
	168	index_type dstride;
	169	GFC_INTEGER_8 *dest;
64acfd99	170	const GFC_REAL_10 *base;
28dc6b33	171	GFC_LOGICAL_1 *mbase;
644cb69f FXC	172	int rank;
644cb69f FXC	173	index_type n;
28dc6b33	174	int mask_kind;
644cb69f FXC	175
	176	rank = GFC_DESCRIPTOR_RANK (array);
	177	if (rank <= 0)
	178	runtime_error ("Rank of array needs to be > 0");
	179
	180	if (retarray->data == NULL)
	181	{
	182	retarray->dim[0].lbound = 0;
	183	retarray->dim[0].ubound = rank-1;
	184	retarray->dim[0].stride = 1;
	185	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	186	retarray->offset = 0;
	187	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank);
	188	}
	189	else
	190	{
9731c4a3	191	if (unlikely (compile_options.bounds_check))
fd6590f8 TK	192	{
	193	int ret_rank, mask_rank;
	194	index_type ret_extent;
	195	int n;
	196	index_type array_extent, mask_extent;
	197
	198	ret_rank = GFC_DESCRIPTOR_RANK (retarray);
	199	if (ret_rank != 1)
	200	runtime_error ("rank of return array in MAXLOC intrinsic"
ccacefc7	201	" should be 1, is %ld", (long int) ret_rank);
fd6590f8 TK	202
	203	ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
	204	if (ret_extent != rank)
	205	runtime_error ("Incorrect extent in return value of"
ccacefc7 TK	206	" MAXLOC intrnisic: is %ld, should be %ld",
ccacefc7 TK	207	(long int) ret_extent, (long int) rank);
fd6590f8 TK	208
	209	mask_rank = GFC_DESCRIPTOR_RANK (mask);
	210	if (rank != mask_rank)
	211	runtime_error ("rank of MASK argument in MAXLOC intrnisic"
ccacefc7 TK	212	"should be %ld, is %ld", (long int) rank,
ccacefc7 TK	213	(long int) mask_rank);
fd6590f8 TK	214
	215	for (n=0; n<rank; n++)
	216	{
	217	array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound;
	218	mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound;
	219	if (array_extent != mask_extent)
	220	runtime_error ("Incorrect extent in MASK argument of"
ccacefc7 TK	221	" MAXLOC intrinsic in dimension %ld:"
ccacefc7 TK	222	" is %ld, should be %ld", (long int) n + 1,
fd6590f8 TK	223	(long int) mask_extent, (long int) array_extent);
	224	}
	225	}
644cb69f FXC	226	}
644cb69f FXC	227
28dc6b33 TK	228	mask_kind = GFC_DESCRIPTOR_SIZE (mask);
	229
	230	mbase = mask->data;
	231
	232	if (mask_kind == 1 \|\| mask_kind == 2 \|\| mask_kind == 4 \|\| mask_kind == 8
	233	#ifdef HAVE_GFC_LOGICAL_16
	234	\|\| mask_kind == 16
	235	#endif
	236	)
	237	mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
	238	else
	239	runtime_error ("Funny sized logical array");
	240
644cb69f FXC	241	dstride = retarray->dim[0].stride;
	242	dest = retarray->data;
	243	for (n = 0; n < rank; n++)
	244	{
	245	sstride[n] = array->dim[n].stride;
28dc6b33	246	mstride[n] = mask->dim[n].stride * mask_kind;
644cb69f FXC	247	extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
	248	count[n] = 0;
	249	if (extent[n] <= 0)
	250	{
	251	/* Set the return value. */
	252	for (n = 0; n < rank; n++)
	253	dest[n * dstride] = 0;
	254	return;
	255	}
	256	}
	257
	258	base = array->data;
644cb69f FXC	259
	260	/* Initialize the return value. */
	261	for (n = 0; n < rank; n++)
a4b9e93e	262	dest[n * dstride] = 0;
644cb69f FXC	263	{
	264
	265	GFC_REAL_10 maxval;
	266
	267	maxval = -GFC_REAL_10_HUGE;
	268
	269	while (base)
	270	{
	271	{
	272	/* Implementation start. */
	273
a4b9e93e	274	if (mbase && (base > maxval \|\| !dest[0]))
644cb69f FXC	275	{
	276	maxval = *base;
	277	for (n = 0; n < rank; n++)
	278	dest[n * dstride] = count[n] + 1;
	279	}
	280	/* Implementation end. */
	281	}
	282	/* Advance to the next element. */
	283	count[0]++;
	284	base += sstride[0];
	285	mbase += mstride[0];
	286	n = 0;
	287	while (count[n] == extent[n])
	288	{
	289	/* When we get to the end of a dimension, reset it and increment
	290	the next dimension. */
	291	count[n] = 0;
	292	/* We could precalculate these products, but this is a less
5d7adf7a	293	frequently used path so probably not worth it. */
644cb69f FXC	294	base -= sstride[n] * extent[n];
	295	mbase -= mstride[n] * extent[n];
	296	n++;
	297	if (n == rank)
	298	{
	299	/* Break out of the loop. */
	300	base = NULL;
	301	break;
	302	}
	303	else
	304	{
	305	count[n]++;
	306	base += sstride[n];
	307	mbase += mstride[n];
	308	}
	309	}
	310	}
	311	}
	312	}
	313
97a62038 TK	314
	315	extern void smaxloc0_8_r10 (gfc_array_i8 * const restrict,
	316	gfc_array_r10 * const restrict, GFC_LOGICAL_4 *);
	317	export_proto(smaxloc0_8_r10);
	318
	319	void
	320	smaxloc0_8_r10 (gfc_array_i8 * const restrict retarray,
	321	gfc_array_r10 * const restrict array,
	322	GFC_LOGICAL_4 * mask)
	323	{
	324	index_type rank;
	325	index_type dstride;
	326	index_type n;
	327	GFC_INTEGER_8 *dest;
	328
	329	if (*mask)
	330	{
	331	maxloc0_8_r10 (retarray, array);
	332	return;
	333	}
	334
	335	rank = GFC_DESCRIPTOR_RANK (array);
	336
	337	if (rank <= 0)
	338	runtime_error ("Rank of array needs to be > 0");
	339
	340	if (retarray->data == NULL)
	341	{
	342	retarray->dim[0].lbound = 0;
	343	retarray->dim[0].ubound = rank-1;
	344	retarray->dim[0].stride = 1;
	345	retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) \| 1;
	346	retarray->offset = 0;
	347	retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank);
	348	}
	349	else
	350	{
9731c4a3	351	if (unlikely (compile_options.bounds_check))
fd6590f8 TK	352	{
	353	int ret_rank;
	354	index_type ret_extent;
97a62038	355
fd6590f8 TK	356	ret_rank = GFC_DESCRIPTOR_RANK (retarray);
	357	if (ret_rank != 1)
	358	runtime_error ("rank of return array in MAXLOC intrinsic"
ccacefc7	359	" should be 1, is %ld", (long int) ret_rank);
fd6590f8 TK	360
	361	ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound;
	362	if (ret_extent != rank)
	363	runtime_error ("dimension of return array incorrect");
	364	}
97a62038 TK	365	}
	366
	367	dstride = retarray->dim[0].stride;
	368	dest = retarray->data;
	369	for (n = 0; n<rank; n++)
	370	dest[n * dstride] = 0 ;
	371	}
644cb69f	372	#endif