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]; } } } }