[thirdparty/gcc.git] / libgfortran / generated / maxloc0_8_i4.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_INTEGER_4) && defined (HAVE_GFC_INTEGER_8)


extern void maxloc0_8_i4 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i4 * const restrict array);
export_proto(maxloc0_8_i4);

void
maxloc0_8_i4 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i4 * 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_INTEGER_4 *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)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 = GFC_DESCRIPTOR_EXTENT(retarray,0);
	  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 = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->data;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      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_INTEGER_4 maxval;

  maxval = (-GFC_INTEGER_4_HUGE-1);

  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_i4 (gfc_array_i8 * const restrict, 
	gfc_array_i4 * const restrict, gfc_array_l1 * const restrict);
export_proto(mmaxloc0_8_i4);

void
mmaxloc0_8_i4 (gfc_array_i8 * const restrict retarray, 
	gfc_array_i4 * 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_INTEGER_4 *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)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 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 = GFC_DESCRIPTOR_EXTENT(retarray,0);
	  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 = GFC_DESCRIPTOR_EXTENT(array,n);
	      mask_extent = GFC_DESCRIPTOR_EXTENT(mask,n);
	      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 = GFC_DESCRIPTOR_STRIDE(retarray,0);
  dest = retarray->data;
  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      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_INTEGER_4 maxval;

  maxval = (-GFC_INTEGER_4_HUGE-1);

  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_i4 (gfc_array_i8 * const restrict, 
	gfc_array_i4 * const restrict, GFC_LOGICAL_4 *);
export_proto(smaxloc0_8_i4);

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

  if (*mask)
    {
      maxloc0_8_i4 (retarray, array);
      return;
    }

  rank = GFC_DESCRIPTOR_RANK (array);

  if (rank <= 0)
    runtime_error ("Rank of array needs to be > 0");

  if (retarray->data == NULL)
    {
      GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 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 = GFC_DESCRIPTOR_EXTENT(retarray,0);
	    if (ret_extent != rank)
	      runtime_error ("dimension of return array incorrect");
	}
    }

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