Commit 802367d7 by Thomas Koenig

re PR fortran/35993 (wrong answer for all array intrinsics with scalar mask)

2008-04-30  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/35993
	* ifunction.m4 (SCALAR_ARRAY_FUNCTION):  Use correct
	implementation for multi-dimensional return arrays when
	the mask is .false.
	* generated/maxloc1_16_i1.c: Regenerated.
	* generated/maxloc1_16_i16.c: Regenerated.
	* generated/maxloc1_16_i2.c: Regenerated.
	* generated/maxloc1_16_i4.c: Regenerated.
	* generated/maxloc1_16_i8.c: Regenerated.
	* generated/maxloc1_16_r10.c: Regenerated.
	* generated/maxloc1_16_r16.c: Regenerated.
	* generated/maxloc1_16_r4.c: Regenerated.
	* generated/maxloc1_16_r8.c: Regenerated.
	* generated/maxloc1_4_i1.c: Regenerated.
	* generated/maxloc1_4_i16.c: Regenerated.
	* generated/maxloc1_4_i2.c: Regenerated.
	* generated/maxloc1_4_i4.c: Regenerated.
	* generated/maxloc1_4_i8.c: Regenerated.
	* generated/maxloc1_4_r10.c: Regenerated.
	* generated/maxloc1_4_r16.c: Regenerated.
	* generated/maxloc1_4_r4.c: Regenerated.
	* generated/maxloc1_4_r8.c: Regenerated.
	* generated/maxloc1_8_i1.c: Regenerated.
	* generated/maxloc1_8_i16.c: Regenerated.
	* generated/maxloc1_8_i2.c: Regenerated.
	* generated/maxloc1_8_i4.c: Regenerated.
	* generated/maxloc1_8_i8.c: Regenerated.
	* generated/maxloc1_8_r10.c: Regenerated.
	* generated/maxloc1_8_r16.c: Regenerated.
	* generated/maxloc1_8_r4.c: Regenerated.
	* generated/maxloc1_8_r8.c: Regenerated.
	* generated/maxval_i1.c: Regenerated.
	* generated/maxval_i16.c: Regenerated.
	* generated/maxval_i2.c: Regenerated.
	* generated/maxval_i4.c: Regenerated.
	* generated/maxval_i8.c: Regenerated.
	* generated/maxval_r10.c: Regenerated.
	* generated/maxval_r16.c: Regenerated.
	* generated/maxval_r4.c: Regenerated.
	* generated/maxval_r8.c: Regenerated.
	* generated/minloc1_16_i1.c: Regenerated.
	* generated/minloc1_16_i16.c: Regenerated.
	* generated/minloc1_16_i2.c: Regenerated.
	* generated/minloc1_16_i4.c: Regenerated.
	* generated/minloc1_16_i8.c: Regenerated.
	* generated/minloc1_16_r10.c: Regenerated.
	* generated/minloc1_16_r16.c: Regenerated.
	* generated/minloc1_16_r4.c: Regenerated.
	* generated/minloc1_16_r8.c: Regenerated.
	* generated/minloc1_4_i1.c: Regenerated.
	* generated/minloc1_4_i16.c: Regenerated.
	* generated/minloc1_4_i2.c: Regenerated.
	* generated/minloc1_4_i4.c: Regenerated.
	* generated/minloc1_4_i8.c: Regenerated.
	* generated/minloc1_4_r10.c: Regenerated.
	* generated/minloc1_4_r16.c: Regenerated.
	* generated/minloc1_4_r4.c: Regenerated.
	* generated/minloc1_4_r8.c: Regenerated.
	* generated/minloc1_8_i1.c: Regenerated.
	* generated/minloc1_8_i16.c: Regenerated.
	* generated/minloc1_8_i2.c: Regenerated.
	* generated/minloc1_8_i4.c: Regenerated.
	* generated/minloc1_8_i8.c: Regenerated.
	* generated/minloc1_8_r10.c: Regenerated.
	* generated/minloc1_8_r16.c: Regenerated.
	* generated/minloc1_8_r4.c: Regenerated.
	* generated/minloc1_8_r8.c: Regenerated.
	* generated/minval_i1.c: Regenerated.
	* generated/minval_i16.c: Regenerated.
	* generated/minval_i2.c: Regenerated.
	* generated/minval_i4.c: Regenerated.
	* generated/minval_i8.c: Regenerated.
	* generated/minval_r10.c: Regenerated.
	* generated/minval_r16.c: Regenerated.
	* generated/minval_r4.c: Regenerated.
	* generated/minval_r8.c: Regenerated.
	* generated/product_c10.c: Regenerated.
	* generated/product_c16.c: Regenerated.
	* generated/product_c4.c: Regenerated.
	* generated/product_c8.c: Regenerated.
	* generated/product_i1.c: Regenerated.
	* generated/product_i16.c: Regenerated.
	* generated/product_i2.c: Regenerated.
	* generated/product_i4.c: Regenerated.
	* generated/product_i8.c: Regenerated.
	* generated/product_r10.c: Regenerated.
	* generated/product_r16.c: Regenerated.
	* generated/product_r4.c: Regenerated.
	* generated/product_r8.c: Regenerated.
	* generated/sum_c10.c: Regenerated.
	* generated/sum_c16.c: Regenerated.
	* generated/sum_c4.c: Regenerated.
	* generated/sum_c8.c: Regenerated.
	* generated/sum_i1.c: Regenerated.
	* generated/sum_i16.c: Regenerated.
	* generated/sum_i2.c: Regenerated.
	* generated/sum_i4.c: Regenerated.
	* generated/sum_i8.c: Regenerated.
	* generated/sum_r10.c: Regenerated.
	* generated/sum_r16.c: Regenerated.
	* generated/sum_r4.c: Regenerated.
	* generated/sum_r8.c: Regenerated.

2008-04-30  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR libfortran/35993
	* gfortran.dg/intrinsic_product_1.f90:  New test case.

From-SVN: r134830
parent 9eec643d
2008-04-30 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/35993
* gfortran.dg/intrinsic_product_1.f90: New test case.
2008-04-30 Richard Guenther <rguenther@suse.de> 2008-04-30 Richard Guenther <rguenther@suse.de>
PR tree-optimization/14847 PR tree-optimization/14847
! { dg-do run }
! PR 35993 - some intrinsics with mask = .false. didn't set
! the whole return array for multi-dimensional arrays.
! Test case adapted from Dick Hendrickson.
program try
call ga3019( 1, 2, 3, 4)
end program
SUBROUTINE GA3019(nf1,nf2,nf3,nf4)
INTEGER IDA(NF2,NF3)
INTEGER IDA1(NF2,NF4,NF3)
ida1 = 3
ida = -3
IDA(NF1:NF2,NF1:NF3) = PRODUCT(IDA1,NF2, NF1 .LT. 0) !fails
if (any(ida /= 1)) call abort
ida = -3
IDA(NF1:NF2,NF1:NF3) = PRODUCT(IDA1,NF2, .false. ) !fails
if (any(ida /= 1)) call abort
ida = -3
IDA(NF1:NF2,NF1:NF3) = PRODUCT(IDA1,NF2, ida1 .eq. 137 ) !works
if (any(ida /= 1)) call abort
END SUBROUTINE
2008-04-30 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/35993
* ifunction.m4 (SCALAR_ARRAY_FUNCTION): Use correct
implementation for multi-dimensional return arrays when
the mask is .false.
* generated/maxloc1_16_i1.c: Regenerated.
* generated/maxloc1_16_i16.c: Regenerated.
* generated/maxloc1_16_i2.c: Regenerated.
* generated/maxloc1_16_i4.c: Regenerated.
* generated/maxloc1_16_i8.c: Regenerated.
* generated/maxloc1_16_r10.c: Regenerated.
* generated/maxloc1_16_r16.c: Regenerated.
* generated/maxloc1_16_r4.c: Regenerated.
* generated/maxloc1_16_r8.c: Regenerated.
* generated/maxloc1_4_i1.c: Regenerated.
* generated/maxloc1_4_i16.c: Regenerated.
* generated/maxloc1_4_i2.c: Regenerated.
* generated/maxloc1_4_i4.c: Regenerated.
* generated/maxloc1_4_i8.c: Regenerated.
* generated/maxloc1_4_r10.c: Regenerated.
* generated/maxloc1_4_r16.c: Regenerated.
* generated/maxloc1_4_r4.c: Regenerated.
* generated/maxloc1_4_r8.c: Regenerated.
* generated/maxloc1_8_i1.c: Regenerated.
* generated/maxloc1_8_i16.c: Regenerated.
* generated/maxloc1_8_i2.c: Regenerated.
* generated/maxloc1_8_i4.c: Regenerated.
* generated/maxloc1_8_i8.c: Regenerated.
* generated/maxloc1_8_r10.c: Regenerated.
* generated/maxloc1_8_r16.c: Regenerated.
* generated/maxloc1_8_r4.c: Regenerated.
* generated/maxloc1_8_r8.c: Regenerated.
* generated/maxval_i1.c: Regenerated.
* generated/maxval_i16.c: Regenerated.
* generated/maxval_i2.c: Regenerated.
* generated/maxval_i4.c: Regenerated.
* generated/maxval_i8.c: Regenerated.
* generated/maxval_r10.c: Regenerated.
* generated/maxval_r16.c: Regenerated.
* generated/maxval_r4.c: Regenerated.
* generated/maxval_r8.c: Regenerated.
* generated/minloc1_16_i1.c: Regenerated.
* generated/minloc1_16_i16.c: Regenerated.
* generated/minloc1_16_i2.c: Regenerated.
* generated/minloc1_16_i4.c: Regenerated.
* generated/minloc1_16_i8.c: Regenerated.
* generated/minloc1_16_r10.c: Regenerated.
* generated/minloc1_16_r16.c: Regenerated.
* generated/minloc1_16_r4.c: Regenerated.
* generated/minloc1_16_r8.c: Regenerated.
* generated/minloc1_4_i1.c: Regenerated.
* generated/minloc1_4_i16.c: Regenerated.
* generated/minloc1_4_i2.c: Regenerated.
* generated/minloc1_4_i4.c: Regenerated.
* generated/minloc1_4_i8.c: Regenerated.
* generated/minloc1_4_r10.c: Regenerated.
* generated/minloc1_4_r16.c: Regenerated.
* generated/minloc1_4_r4.c: Regenerated.
* generated/minloc1_4_r8.c: Regenerated.
* generated/minloc1_8_i1.c: Regenerated.
* generated/minloc1_8_i16.c: Regenerated.
* generated/minloc1_8_i2.c: Regenerated.
* generated/minloc1_8_i4.c: Regenerated.
* generated/minloc1_8_i8.c: Regenerated.
* generated/minloc1_8_r10.c: Regenerated.
* generated/minloc1_8_r16.c: Regenerated.
* generated/minloc1_8_r4.c: Regenerated.
* generated/minloc1_8_r8.c: Regenerated.
* generated/minval_i1.c: Regenerated.
* generated/minval_i16.c: Regenerated.
* generated/minval_i2.c: Regenerated.
* generated/minval_i4.c: Regenerated.
* generated/minval_i8.c: Regenerated.
* generated/minval_r10.c: Regenerated.
* generated/minval_r16.c: Regenerated.
* generated/minval_r4.c: Regenerated.
* generated/minval_r8.c: Regenerated.
* generated/product_c10.c: Regenerated.
* generated/product_c16.c: Regenerated.
* generated/product_c4.c: Regenerated.
* generated/product_c8.c: Regenerated.
* generated/product_i1.c: Regenerated.
* generated/product_i16.c: Regenerated.
* generated/product_i2.c: Regenerated.
* generated/product_i4.c: Regenerated.
* generated/product_i8.c: Regenerated.
* generated/product_r10.c: Regenerated.
* generated/product_r16.c: Regenerated.
* generated/product_r4.c: Regenerated.
* generated/product_r8.c: Regenerated.
* generated/sum_c10.c: Regenerated.
* generated/sum_c16.c: Regenerated.
* generated/sum_c4.c: Regenerated.
* generated/sum_c8.c: Regenerated.
* generated/sum_i1.c: Regenerated.
* generated/sum_i16.c: Regenerated.
* generated/sum_i2.c: Regenerated.
* generated/sum_i4.c: Regenerated.
* generated/sum_i8.c: Regenerated.
* generated/sum_r10.c: Regenerated.
* generated/sum_r16.c: Regenerated.
* generated/sum_r4.c: Regenerated.
* generated/sum_r8.c: Regenerated.
2008-04-25 Thomas Koenig <tkoenig@gcc.gnu.org> 2008-04-25 Thomas Koenig <tkoenig@gcc.gnu.org>
PR libfortran/35960 PR libfortran/35960
......
...@@ -428,51 +428,131 @@ smaxloc1_16_i1 (gfc_array_i16 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_16_i1 (gfc_array_i16 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_16 *dest;
if (*mask) if (*mask)
{ {
maxloc1_16_i1 (retarray, array, pdim); maxloc1_16_i1 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_16_i16 (gfc_array_i16 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_16_i16 (gfc_array_i16 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_16 *dest;
if (*mask) if (*mask)
{ {
maxloc1_16_i16 (retarray, array, pdim); maxloc1_16_i16 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_16_i2 (gfc_array_i16 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_16_i2 (gfc_array_i16 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_16 *dest;
if (*mask) if (*mask)
{ {
maxloc1_16_i2 (retarray, array, pdim); maxloc1_16_i2 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_16_i4 (gfc_array_i16 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_16_i4 (gfc_array_i16 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_16 *dest;
if (*mask) if (*mask)
{ {
maxloc1_16_i4 (retarray, array, pdim); maxloc1_16_i4 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_16_i8 (gfc_array_i16 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_16_i8 (gfc_array_i16 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_16 *dest;
if (*mask) if (*mask)
{ {
maxloc1_16_i8 (retarray, array, pdim); maxloc1_16_i8 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_16_r10 (gfc_array_i16 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_16_r10 (gfc_array_i16 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_16 *dest;
if (*mask) if (*mask)
{ {
maxloc1_16_r10 (retarray, array, pdim); maxloc1_16_r10 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_16_r16 (gfc_array_i16 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_16_r16 (gfc_array_i16 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_16 *dest;
if (*mask) if (*mask)
{ {
maxloc1_16_r16 (retarray, array, pdim); maxloc1_16_r16 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_16_r4 (gfc_array_i16 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_16_r4 (gfc_array_i16 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_16 *dest;
if (*mask) if (*mask)
{ {
maxloc1_16_r4 (retarray, array, pdim); maxloc1_16_r4 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_16_r8 (gfc_array_i16 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_16_r8 (gfc_array_i16 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_16 *dest;
if (*mask) if (*mask)
{ {
maxloc1_16_r8 (retarray, array, pdim); maxloc1_16_r8 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_4_i1 (gfc_array_i4 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_4_i1 (gfc_array_i4 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_4 *dest;
if (*mask) if (*mask)
{ {
maxloc1_4_i1 (retarray, array, pdim); maxloc1_4_i1 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_4_i16 (gfc_array_i4 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_4_i16 (gfc_array_i4 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_4 *dest;
if (*mask) if (*mask)
{ {
maxloc1_4_i16 (retarray, array, pdim); maxloc1_4_i16 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_4_i2 (gfc_array_i4 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_4_i2 (gfc_array_i4 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_4 *dest;
if (*mask) if (*mask)
{ {
maxloc1_4_i2 (retarray, array, pdim); maxloc1_4_i2 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_4_i4 (gfc_array_i4 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_4_i4 (gfc_array_i4 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_4 *dest;
if (*mask) if (*mask)
{ {
maxloc1_4_i4 (retarray, array, pdim); maxloc1_4_i4 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_4_i8 (gfc_array_i4 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_4_i8 (gfc_array_i4 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_4 *dest;
if (*mask) if (*mask)
{ {
maxloc1_4_i8 (retarray, array, pdim); maxloc1_4_i8 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_4_r10 (gfc_array_i4 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_4_r10 (gfc_array_i4 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_4 *dest;
if (*mask) if (*mask)
{ {
maxloc1_4_r10 (retarray, array, pdim); maxloc1_4_r10 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_4_r16 (gfc_array_i4 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_4_r16 (gfc_array_i4 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_4 *dest;
if (*mask) if (*mask)
{ {
maxloc1_4_r16 (retarray, array, pdim); maxloc1_4_r16 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_4_r4 (gfc_array_i4 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_4_r4 (gfc_array_i4 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_4 *dest;
if (*mask) if (*mask)
{ {
maxloc1_4_r4 (retarray, array, pdim); maxloc1_4_r4 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_4_r8 (gfc_array_i4 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_4_r8 (gfc_array_i4 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_4 *dest;
if (*mask) if (*mask)
{ {
maxloc1_4_r8 (retarray, array, pdim); maxloc1_4_r8 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_8_i1 (gfc_array_i8 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_8_i1 (gfc_array_i8 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_8 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_8 *dest;
if (*mask) if (*mask)
{ {
maxloc1_8_i1 (retarray, array, pdim); maxloc1_8_i1 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = -1;
return;
}
else
retarray->data = internal_malloc_size (alloc_size);
} }
else else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_8_i16 (gfc_array_i8 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_8_i16 (gfc_array_i8 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_8 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_8 *dest;
if (*mask) if (*mask)
{ {
maxloc1_8_i16 (retarray, array, pdim); maxloc1_8_i16 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = -1;
return;
}
else
retarray->data = internal_malloc_size (alloc_size);
} }
else else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_8_i2 (gfc_array_i8 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_8_i2 (gfc_array_i8 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_8 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_8 *dest;
if (*mask) if (*mask)
{ {
maxloc1_8_i2 (retarray, array, pdim); maxloc1_8_i2 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = -1;
return;
}
else
retarray->data = internal_malloc_size (alloc_size);
} }
else else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_8_i4 (gfc_array_i8 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_8_i4 (gfc_array_i8 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_8 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_8 *dest;
if (*mask) if (*mask)
{ {
maxloc1_8_i4 (retarray, array, pdim); maxloc1_8_i4 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = -1;
return;
}
else
retarray->data = internal_malloc_size (alloc_size);
} }
else else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_8_i8 (gfc_array_i8 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_8_i8 (gfc_array_i8 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_8 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_8 *dest;
if (*mask) if (*mask)
{ {
maxloc1_8_i8 (retarray, array, pdim); maxloc1_8_i8 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = -1;
return;
}
else
retarray->data = internal_malloc_size (alloc_size);
} }
else else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_8_r10 (gfc_array_i8 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_8_r10 (gfc_array_i8 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_8 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_8 *dest;
if (*mask) if (*mask)
{ {
maxloc1_8_r10 (retarray, array, pdim); maxloc1_8_r10 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = -1;
return;
}
else
retarray->data = internal_malloc_size (alloc_size);
} }
else else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_8_r16 (gfc_array_i8 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_8_r16 (gfc_array_i8 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_8 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_8 *dest;
if (*mask) if (*mask)
{ {
maxloc1_8_r16 (retarray, array, pdim); maxloc1_8_r16 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = -1;
return;
}
else
retarray->data = internal_malloc_size (alloc_size);
} }
else else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_8_r4 (gfc_array_i8 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_8_r4 (gfc_array_i8 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_8 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_8 *dest;
if (*mask) if (*mask)
{ {
maxloc1_8_r4 (retarray, array, pdim); maxloc1_8_r4 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = -1;
return;
}
else
retarray->data = internal_malloc_size (alloc_size);
} }
else else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -428,51 +428,131 @@ smaxloc1_8_r8 (gfc_array_i8 * const restrict retarray, ...@@ -428,51 +428,131 @@ smaxloc1_8_r8 (gfc_array_i8 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_8 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_8 *dest;
if (*mask) if (*mask)
{ {
maxloc1_8_r8 (retarray, array, pdim); maxloc1_8_r8 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
* extent[rank-1];
if (alloc_size == 0)
{
/* Make sure we have a zero-sized array. */
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = -1;
return;
}
else
retarray->data = internal_malloc_size (alloc_size);
} }
else else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXLOC intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
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; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); if (extent[n] != ret_extent)
runtime_error ("Incorrect extent in return value of"
" MAXLOC intrinsic in dimension %ld:"
" is %ld, should be %ld", (long int) n + 1,
(long int) ret_extent, (long int) extent[n]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = 0 ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = 0;
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 #endif
...@@ -417,51 +417,131 @@ smaxval_i1 (gfc_array_i1 * const restrict retarray, ...@@ -417,51 +417,131 @@ smaxval_i1 (gfc_array_i1 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_1 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_1 *dest;
if (*mask) if (*mask)
{ {
maxval_i1 (retarray, array, pdim); maxval_i1 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_1) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_1) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
index_type ret_extent;
ret_rank = GFC_DESCRIPTOR_RANK (retarray);
if (ret_rank != 1)
runtime_error ("rank of return array in MAXVAL intrinsic"
" should be 1, is %ld", (long int) ret_rank);
ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); 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]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = (-GFC_INTEGER_1_HUGE-1) ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = (-GFC_INTEGER_1_HUGE-1);
count[0]++;
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
dest -= dstride[n] * extent[n];
n++;
if (n == rank)
return;
else
{
count[n]++;
dest += dstride[n];
}
}
}
} }
#endif #endif
...@@ -417,51 +417,131 @@ smaxval_i16 (gfc_array_i16 * const restrict retarray, ...@@ -417,51 +417,131 @@ smaxval_i16 (gfc_array_i16 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_16 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_16 *dest;
if (*mask) if (*mask)
{ {
maxval_i16 (retarray, array, pdim); maxval_i16 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_16) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_16) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
index_type ret_extent;
ret_rank = GFC_DESCRIPTOR_RANK (retarray);
if (ret_rank != 1)
runtime_error ("rank of return array in MAXVAL intrinsic"
" should be 1, is %ld", (long int) ret_rank);
ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); 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]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = (-GFC_INTEGER_16_HUGE-1) ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = (-GFC_INTEGER_16_HUGE-1);
count[0]++;
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
dest -= dstride[n] * extent[n];
n++;
if (n == rank)
return;
else
{
count[n]++;
dest += dstride[n];
}
}
}
} }
#endif #endif
...@@ -417,51 +417,131 @@ smaxval_i2 (gfc_array_i2 * const restrict retarray, ...@@ -417,51 +417,131 @@ smaxval_i2 (gfc_array_i2 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_2 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_2 *dest;
if (*mask) if (*mask)
{ {
maxval_i2 (retarray, array, pdim); maxval_i2 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_2) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_2) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
index_type ret_extent;
ret_rank = GFC_DESCRIPTOR_RANK (retarray);
if (ret_rank != 1)
runtime_error ("rank of return array in MAXVAL intrinsic"
" should be 1, is %ld", (long int) ret_rank);
ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); 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]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = (-GFC_INTEGER_2_HUGE-1) ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = (-GFC_INTEGER_2_HUGE-1);
count[0]++;
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
dest -= dstride[n] * extent[n];
n++;
if (n == rank)
return;
else
{
count[n]++;
dest += dstride[n];
}
}
}
} }
#endif #endif
...@@ -417,51 +417,131 @@ smaxval_i4 (gfc_array_i4 * const restrict retarray, ...@@ -417,51 +417,131 @@ smaxval_i4 (gfc_array_i4 * const restrict retarray,
const index_type * const restrict pdim, const index_type * const restrict pdim,
GFC_LOGICAL_4 * mask) GFC_LOGICAL_4 * mask)
{ {
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
GFC_INTEGER_4 * restrict dest;
index_type rank; index_type rank;
index_type n; index_type n;
index_type dstride; index_type dim;
GFC_INTEGER_4 *dest;
if (*mask) if (*mask)
{ {
maxval_i4 (retarray, array, pdim); maxval_i4 (retarray, array, pdim);
return; return;
} }
rank = GFC_DESCRIPTOR_RANK (array); /* Make dim zero based to avoid confusion. */
if (rank <= 0) dim = (*pdim) - 1;
runtime_error ("Rank of array needs to be > 0"); 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) if (retarray->data == NULL)
{ {
retarray->dim[0].lbound = 0; size_t alloc_size;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1; for (n = 0; n < rank; n++)
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; {
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->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank); retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
alloc_size = sizeof (GFC_INTEGER_4) * 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 else
{ {
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect in"
" MAXVAL intrinsic: is %ld, should be %ld",
(long int) (GFC_DESCRIPTOR_RANK (retarray)),
(long int) rank);
if (compile_options.bounds_check) if (compile_options.bounds_check)
{ {
int ret_rank; for (n=0; n < rank; n++)
index_type ret_extent; {
index_type ret_extent;
ret_rank = GFC_DESCRIPTOR_RANK (retarray);
if (ret_rank != 1)
runtime_error ("rank of return array in MAXVAL intrinsic"
" should be 1, is %ld", (long int) ret_rank);
ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; ret_extent = retarray->dim[n].ubound + 1
if (ret_extent != rank) - retarray->dim[n].lbound;
runtime_error ("dimension of return array incorrect"); 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]);
}
} }
} }
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++) for (n = 0; n < rank; n++)
dest[n * dstride] = (-GFC_INTEGER_4_HUGE-1) ; {
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
}
dest = retarray->data;
while(1)
{
*dest = (-GFC_INTEGER_4_HUGE-1);
count[0]++;
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so probably not worth it. */
dest -= dstride[n] * extent[n];
n++;
if (n == rank)
return;
else
{
count[n]++;
dest += dstride[n];
}
}
}
} }
#endif #endif
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment