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

/* Implementation of the MINLOC intrinsic
   Copyright 2002, 2007 Free Software Foundation, Inc.
   Contributed by Paul Brook <paul@nowt.org>

This file is part of the GNU Fortran 95 runtime library (libgfortran).

Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.

In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file.  (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)

Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public
License along with libgfortran; see the file COPYING.  If not,
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */

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


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


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

void
minloc0_4_i8 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i8 * 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_8 *base;
  GFC_INTEGER_4 * 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_4) * 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 MINLOC 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"
			   " MINLOC 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_INTEGER_8 minval;

  minval = GFC_INTEGER_8_HUGE;

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

  if (*base < minval || !dest[0])
    {
      minval = *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 mminloc0_4_i8 (gfc_array_i4 * const restrict, 
	gfc_array_i8 * const restrict, gfc_array_l1 * const restrict);
export_proto(mminloc0_4_i8);

void
mminloc0_4_i8 (gfc_array_i4 * const restrict retarray, 
	gfc_array_i8 * 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_4 *dest;
  const GFC_INTEGER_8 *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_4) * 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 MINLOC 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"
			   " MINLOC 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 MINLOC 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"
			       " MINLOC 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_INTEGER_8 minval;

  minval = GFC_INTEGER_8_HUGE;

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

  if (*mbase && (*base < minval || !dest[0]))
    {
      minval = *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 sminloc0_4_i8 (gfc_array_i4 * const restrict, 
	gfc_array_i8 * const restrict, GFC_LOGICAL_4 *);
export_proto(sminloc0_4_i8);

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

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