GFC_LOGICAL_4
dot_product_l4 (gfc_array_l4 * a, gfc_array_l4 * b)
{
GFC_LOGICAL_4 *pa;
GFC_LOGICAL_4 *pb;
index_type count;
index_type astride;
index_type bstride;
assert (GFC_DESCRIPTOR_RANK (a) == 1
&& GFC_DESCRIPTOR_RANK (b) == 1);
if (a->dim[0].stride == 0)
a->dim[0].stride = 1;
if (b->dim[0].stride == 0)
b->dim[0].stride = 1;
astride = a->dim[0].stride;
bstride = b->dim[0].stride;
count = a->dim[0].ubound + 1 - a->dim[0].lbound;
pa = a->data;
if (GFC_DESCRIPTOR_SIZE (a) != 4)
{
assert (GFC_DESCRIPTOR_SIZE (a) == 8);
pa = GFOR_POINTER_L8_TO_L4 (pa);
astride <<= 1;
}
pb = b->data;
if (GFC_DESCRIPTOR_SIZE (b) != 4)
{
assert (GFC_DESCRIPTOR_SIZE (b) == 8);
pb = GFOR_POINTER_L8_TO_L4 (pb);
bstride <<= 1;
}
while (count--)
{
if (*pa && *pb)
return 1;
pa += astride;
pb += bstride;
}
return 0;
}
void
mminloc0_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 *array,
gfc_array_l4 * mask)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
GFC_INTEGER_8 *dest;
GFC_REAL_8 *base;
GFC_LOGICAL_4 *mbase;
int rank;
index_type n;
rank = GFC_DESCRIPTOR_RANK (array);
if (rank <= 0)
runtime_error ("Rank of array needs to be > 0");
if (retarray->data == NULL)
{
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = rank-1;
retarray->dim[0].stride = 1;
retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
retarray->offset = 0;
retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank);
}
else
{
if (GFC_DESCRIPTOR_RANK (retarray) != 1)
runtime_error ("rank of return array does not equal 1");
if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
runtime_error ("dimension of return array incorrect");
if (retarray->dim[0].stride == 0)
retarray->dim[0].stride = 1;
}
/* TODO: It should be a front end job to correctly set the strides. */
if (array->dim[0].stride == 0)
array->dim[0].stride = 1;
if (mask->dim[0].stride == 0)
mask->dim[0].stride = 1;
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++)
{
sstride[n] = array->dim[n].stride;
mstride[n] = mask->dim[n].stride;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
count[n] = 0;
if (extent[n] <= 0)
{
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
return;
}
}
base = array->data;
mbase = mask->data;
if (GFC_DESCRIPTOR_SIZE (mask) != 4)
{
/* This allows the same loop to be used for all logical types. */
assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
for (n = 0; n < rank; n++)
mstride[n] <<= 1;
mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
}
/* Initialize the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
{
GFC_REAL_8 minval;
minval = GFC_REAL_8_HUGE;
while (base)
{
{
/* Implementation start. */
if (*mbase && (*base < minval || !dest[0]))
{
minval = *base;
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
}
/* Implementation end. */
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
mbase += mstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so proabably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
n++;
if (n == rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
}
}
}
}
}
void
__mmaxloc1_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 * array, index_type *pdim, gfc_array_l4 * mask)
{
index_type count[GFC_MAX_DIMENSIONS - 1];
index_type extent[GFC_MAX_DIMENSIONS - 1];
index_type sstride[GFC_MAX_DIMENSIONS - 1];
index_type dstride[GFC_MAX_DIMENSIONS - 1];
index_type mstride[GFC_MAX_DIMENSIONS - 1];
GFC_INTEGER_8 *dest;
GFC_REAL_8 *base;
GFC_LOGICAL_4 *mbase;
int rank;
int dim;
index_type n;
index_type len;
index_type delta;
index_type mdelta;
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
assert (rank == GFC_DESCRIPTOR_RANK (retarray));
if (array->dim[0].stride == 0)
array->dim[0].stride = 1;
if (retarray->dim[0].stride == 0)
retarray->dim[0].stride = 1;
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
if (len <= 0)
return;
delta = array->dim[dim].stride;
mdelta = mask->dim[dim].stride;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
mstride[n] = mask->dim[n].stride;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
mstride[n] = mask->dim[n + 1].stride;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
if (extent[n] <= 0)
return;
}
dest = retarray->data;
base = array->data;
mbase = mask->data;
if (GFC_DESCRIPTOR_SIZE (mask) != 4)
{
/* This allows the same loop to be used for all logical types. */
assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
for (n = 0; n < rank; n++)
mstride[n] <<= 1;
mdelta <<= 1;
mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
}
while (base)
{
GFC_REAL_8 *src;
GFC_LOGICAL_4 *msrc;
GFC_INTEGER_8 result;
src = base;
msrc = mbase;
{
GFC_REAL_8 maxval;
maxval = -GFC_REAL_8_HUGE;
result = 1;
if (len <= 0)
*dest = 0;
else
{
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc && *src > maxval)
{
maxval = *src;
result = (GFC_INTEGER_8)n + 1;
}
}
*dest = result;
}
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
mbase += mstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so proabably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n == rank)
{
/* Break out of the look. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
dest += dstride[n];
}
}
}
}
void
mmaxval_r4 (gfc_array_r4 * retarray, gfc_array_r4 * array,
index_type *pdim, gfc_array_l4 * mask)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type dstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
GFC_REAL_4 *dest;
GFC_REAL_4 *base;
GFC_LOGICAL_4 *mbase;
int rank;
int dim;
index_type n;
index_type len;
index_type delta;
index_type mdelta;
dim = (*pdim) - 1;
rank = GFC_DESCRIPTOR_RANK (array) - 1;
/* TODO: It should be a front end job to correctly set the strides. */
if (array->dim[0].stride == 0)
array->dim[0].stride = 1;
if (mask->dim[0].stride == 0)
mask->dim[0].stride = 1;
len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
if (len <= 0)
return;
delta = array->dim[dim].stride;
mdelta = mask->dim[dim].stride;
for (n = 0; n < dim; n++)
{
sstride[n] = array->dim[n].stride;
mstride[n] = mask->dim[n].stride;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
}
for (n = dim; n < rank; n++)
{
sstride[n] = array->dim[n + 1].stride;
mstride[n] = mask->dim[n + 1].stride;
extent[n] =
array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
}
if (retarray->data == NULL)
{
for (n = 0; n < rank; n++)
{
retarray->dim[n].lbound = 0;
retarray->dim[n].ubound = extent[n]-1;
if (n == 0)
retarray->dim[n].stride = 1;
else
retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
}
retarray->data
= internal_malloc_size (sizeof (GFC_REAL_4)
* retarray->dim[rank-1].stride
* extent[rank-1]);
retarray->base = 0;
retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
}
else
{
if (retarray->dim[0].stride == 0)
retarray->dim[0].stride = 1;
if (rank != GFC_DESCRIPTOR_RANK (retarray))
runtime_error ("rank of return array incorrect");
}
for (n = 0; n < rank; n++)
{
count[n] = 0;
dstride[n] = retarray->dim[n].stride;
if (extent[n] <= 0)
return;
}
dest = retarray->data;
base = array->data;
mbase = mask->data;
if (GFC_DESCRIPTOR_SIZE (mask) != 4)
{
/* This allows the same loop to be used for all logical types. */
assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
for (n = 0; n < rank; n++)
mstride[n] <<= 1;
mdelta <<= 1;
mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
}
while (base)
{
GFC_REAL_4 *src;
GFC_LOGICAL_4 *msrc;
GFC_REAL_4 result;
src = base;
msrc = mbase;
{
result = -GFC_REAL_4_HUGE;
if (len <= 0)
*dest = -GFC_REAL_4_HUGE;
else
{
for (n = 0; n < len; n++, src += delta, msrc += mdelta)
{
if (*msrc && *src > result)
result = *src;
}
*dest = result;
}
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
mbase += mstride[0];
dest += dstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so proabably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n == rank)
{
/* Break out of the look. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
dest += dstride[n];
}
}
}
}
void
__mmaxloc0_4_r4 (gfc_array_i4 * retarray, gfc_array_r4 *array, gfc_array_l4 * mask)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type sstride[GFC_MAX_DIMENSIONS];
index_type mstride[GFC_MAX_DIMENSIONS];
index_type dstride;
GFC_INTEGER_4 *dest;
GFC_REAL_4 *base;
GFC_LOGICAL_4 *mbase;
int rank;
index_type n;
rank = GFC_DESCRIPTOR_RANK (array);
assert (rank > 0);
assert (GFC_DESCRIPTOR_RANK (retarray) == 1);
assert (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound == rank);
assert (GFC_DESCRIPTOR_RANK (mask) == rank);
if (array->dim[0].stride == 0)
array->dim[0].stride = 1;
if (retarray->dim[0].stride == 0)
retarray->dim[0].stride = 1;
if (retarray->dim[0].stride == 0)
retarray->dim[0].stride = 1;
dstride = retarray->dim[0].stride;
dest = retarray->data;
for (n = 0; n < rank; n++)
{
sstride[n] = array->dim[n].stride;
mstride[n] = mask->dim[n].stride;
extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
count[n] = 0;
if (extent[n] <= 0)
{
/* Set the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 0;
return;
}
}
base = array->data;
mbase = mask->data;
if (GFC_DESCRIPTOR_SIZE (mask) != 4)
{
/* This allows the same loop to be used for all logical types. */
assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
for (n = 0; n < rank; n++)
mstride[n] <<= 1;
mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
}
/* Initialize the return value. */
for (n = 0; n < rank; n++)
dest[n * dstride] = 1;
{
GFC_REAL_4 maxval;
maxval = -GFC_REAL_4_HUGE;
while (base)
{
{
/* Implementation start. */
if (*mbase && *base > maxval)
{
maxval = *base;
for (n = 0; n < rank; n++)
dest[n * dstride] = count[n] + 1;
}
/* Implementation end. */
}
/* Advance to the next element. */
count[0]++;
base += sstride[0];
mbase += mstride[0];
n = 0;
while (count[n] == extent[n])
{
/* When we get to the end of a dimension, reset it and increment
the next dimension. */
count[n] = 0;
/* We could precalculate these products, but this is a less
frequently used path so proabably not worth it. */
base -= sstride[n] * extent[n];
mbase -= mstride[n] * extent[n];
n++;
if (n == rank)
{
/* Break out of the loop. */
base = NULL;
break;
}
else
{
count[n]++;
base += sstride[n];
mbase += mstride[n];
}
}
}
}
}
void
matmul_l8 (gfc_array_l8 * retarray, gfc_array_l4 * a, gfc_array_l4 * b)
{
GFC_INTEGER_4 *abase;
GFC_INTEGER_4 *bbase;
GFC_LOGICAL_8 *dest;
index_type rxstride;
index_type rystride;
index_type xcount;
index_type ycount;
index_type xstride;
index_type ystride;
index_type x;
index_type y;
GFC_INTEGER_4 *pa;
GFC_INTEGER_4 *pb;
index_type astride;
index_type bstride;
index_type count;
index_type n;
assert (GFC_DESCRIPTOR_RANK (a) == 2
|| GFC_DESCRIPTOR_RANK (b) == 2);
if (retarray->data == NULL)
{
if (GFC_DESCRIPTOR_RANK (a) == 1)
{
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = b->dim[1].ubound - b->dim[1].lbound;
retarray->dim[0].stride = 1;
}
else if (GFC_DESCRIPTOR_RANK (b) == 1)
{
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound;
retarray->dim[0].stride = 1;
}
else
{
retarray->dim[0].lbound = 0;
retarray->dim[0].ubound = a->dim[0].ubound - a->dim[0].lbound;
retarray->dim[0].stride = 1;
retarray->dim[1].lbound = 0;
retarray->dim[1].ubound = b->dim[1].ubound - b->dim[1].lbound;
retarray->dim[1].stride = retarray->dim[0].ubound+1;
}
retarray->data
= internal_malloc_size (sizeof (GFC_LOGICAL_8) * size0 ((array_t *) retarray));
retarray->base = 0;
}
abase = a->data;
if (GFC_DESCRIPTOR_SIZE (a) != 4)
{
assert (GFC_DESCRIPTOR_SIZE (a) == 8);
abase = GFOR_POINTER_L8_TO_L4 (abase);
}
bbase = b->data;
if (GFC_DESCRIPTOR_SIZE (b) != 4)
{
assert (GFC_DESCRIPTOR_SIZE (b) == 8);
bbase = GFOR_POINTER_L8_TO_L4 (bbase);
}
dest = retarray->data;
if (retarray->dim[0].stride == 0)
retarray->dim[0].stride = 1;
if (a->dim[0].stride == 0)
a->dim[0].stride = 1;
if (b->dim[0].stride == 0)
b->dim[0].stride = 1;
if (GFC_DESCRIPTOR_RANK (retarray) == 1)
{
rxstride = retarray->dim[0].stride;
rystride = rxstride;
}
else
{
rxstride = retarray->dim[0].stride;
rystride = retarray->dim[1].stride;
}
/* If we have rank 1 parameters, zero the absent stride, and set the size to
one. */
if (GFC_DESCRIPTOR_RANK (a) == 1)
{
astride = a->dim[0].stride;
count = a->dim[0].ubound + 1 - a->dim[0].lbound;
xstride = 0;
rxstride = 0;
xcount = 1;
}
else
{
astride = a->dim[1].stride;
count = a->dim[1].ubound + 1 - a->dim[1].lbound;
xstride = a->dim[0].stride;
xcount = a->dim[0].ubound + 1 - a->dim[0].lbound;
}
if (GFC_DESCRIPTOR_RANK (b) == 1)
{
bstride = b->dim[0].stride;
assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound);
ystride = 0;
rystride = 0;
ycount = 1;
}
else
{
bstride = b->dim[0].stride;
assert(count == b->dim[0].ubound + 1 - b->dim[0].lbound);
ystride = b->dim[1].stride;
ycount = b->dim[1].ubound + 1 - b->dim[1].lbound;
}
for (y = 0; y < ycount; y++)
{
for (x = 0; x < xcount; x++)
{
/* Do the summation for this element. For real and integer types
this is the same as DOT_PRODUCT. For complex types we use do
a*b, not conjg(a)*b. */
pa = abase;
pb = bbase;
*dest = 0;
for (n = 0; n < count; n++)
{
if (*pa && *pb)
{
*dest = 1;
break;
}
pa += astride;
pb += bstride;
}
dest += rxstride;
abase += xstride;
}
abase -= xstride * xcount;
bbase += ystride;
dest += rystride - (rxstride * xcount);
}
}
void
unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
const gfc_array_l4 *mask, const gfc_array_char *field)
{
/* r.* indicates the return array. */
index_type rstride[GFC_MAX_DIMENSIONS];
index_type rstride0;
index_type rs;
char *rptr;
/* v.* indicates the vector array. */
index_type vstride0;
char *vptr;
/* f.* indicates the field array. */
index_type fstride[GFC_MAX_DIMENSIONS];
index_type fstride0;
const char *fptr;
/* m.* indicates the mask array. */
index_type mstride[GFC_MAX_DIMENSIONS];
index_type mstride0;
const GFC_LOGICAL_4 *mptr;
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
index_type n;
index_type dim;
index_type size;
index_type fsize;
size = GFC_DESCRIPTOR_SIZE (ret);
/* A field element size of 0 actually means this is a scalar. */
fsize = GFC_DESCRIPTOR_SIZE (field);
if (ret->data == NULL)
{
/* The front end has signalled that we need to populate the
return array descriptor. */
dim = GFC_DESCRIPTOR_RANK (mask);
rs = 1;
for (n = 0; n < dim; n++)
{
count[n] = 0;
ret->dim[n].stride = rs;
ret->dim[n].lbound = 0;
ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
extent[n] = ret->dim[n].ubound + 1;
rstride[n] = ret->dim[n].stride * size;
fstride[n] = field->dim[n].stride * fsize;
mstride[n] = mask->dim[n].stride;
rs *= extent[n];
}
ret->base = 0;
ret->data = internal_malloc_size (rs * size);
}
else
{
dim = GFC_DESCRIPTOR_RANK (ret);
for (n = 0; n < dim; n++)
{
count[n] = 0;
extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
rstride[n] = ret->dim[n].stride * size;
fstride[n] = field->dim[n].stride * fsize;
mstride[n] = mask->dim[n].stride;
}
if (rstride[0] == 0)
rstride[0] = size;
}
if (fstride[0] == 0)
fstride[0] = fsize;
if (mstride[0] == 0)
mstride[0] = 1;
vstride0 = vector->dim[0].stride * size;
if (vstride0 == 0)
vstride0 = size;
rstride0 = rstride[0];
fstride0 = fstride[0];
mstride0 = mstride[0];
rptr = ret->data;
fptr = field->data;
mptr = mask->data;
vptr = vector->data;
/* Use the same loop for both logical types. */
if (GFC_DESCRIPTOR_SIZE (mask) != 4)
{
if (GFC_DESCRIPTOR_SIZE (mask) != 8)
runtime_error ("Funny sized logical array");
for (n = 0; n < dim; n++)
mstride[n] <<= 1;
mstride0 <<= 1;
mptr = GFOR_POINTER_L8_TO_L4 (mptr);
}
while (rptr)
{
if (*mptr)
{
/* From vector. */
memcpy (rptr, vptr, size);
vptr += vstride0;
}
else
{
/* From field. */
memcpy (rptr, fptr, size);
}
/* Advance to the next element. */
rptr += rstride0;
fptr += fstride0;
mptr += mstride0;
count[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 proabably not worth it. */
rptr -= rstride[n] * extent[n];
fptr -= fstride[n] * extent[n];
mptr -= mstride[n] * extent[n];
n++;
if (n >= dim)
{
/* Break out of the loop. */
rptr = NULL;
break;
}
else
{
count[n]++;
rptr += rstride[n];
fptr += fstride[n];
mptr += mstride[n];
}
}
}
}
