C++ GFC_DESCRIPTOR_RANK函数代码示例

void
eoshift3_8 (gfc_array_char *ret, gfc_array_char *array,
		       gfc_array_i8 *h, const gfc_array_char *bound,
		       GFC_INTEGER_8 *pwhich)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type roffset;
  char *rptr;
  char *dest;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type soffset;
  const char *sptr;
  const char *src;
  /* h.* indicates the shift array.  */
  index_type hstride[GFC_MAX_DIMENSIONS];
  index_type hstride0;
  const GFC_INTEGER_8 *hptr;
  /* b.* indicates the bound array.  */
  index_type bstride[GFC_MAX_DIMENSIONS];
  index_type bstride0;
  const char *bptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dim;
  index_type size;
  index_type len;
  index_type n;
  int which;
  GFC_INTEGER_8 sh;
  GFC_INTEGER_8 delta;

  if (pwhich)
    which = *pwhich - 1;
  else
    which = 0;

  size = GFC_DESCRIPTOR_SIZE (ret);

  extent[0] = 1;
  count[0] = 0;
  size = GFC_DESCRIPTOR_SIZE (array);
  n = 0;
  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
    {
      if (dim == which)
        {
          roffset = ret->dim[dim].stride * size;
          if (roffset == 0)
            roffset = size;
          soffset = array->dim[dim].stride * size;
          if (soffset == 0)
            soffset = size;
          len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
        }
      else
        {
          count[n] = 0;
          extent[n] = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
          rstride[n] = ret->dim[dim].stride * size;
          sstride[n] = array->dim[dim].stride * size;

          hstride[n] = h->dim[n].stride;
          if (bound)
            bstride[n] = bound->dim[n].stride;
          else
            bstride[n] = 0;
          n++;
        }
    }
  if (sstride[0] == 0)
    sstride[0] = size;
  if (rstride[0] == 0)
    rstride[0] = size;
  if (hstride[0] == 0)
    hstride[0] = 1;
  if (bound && bstride[0] == 0)
    bstride[0] = size;

  dim = GFC_DESCRIPTOR_RANK (array);
  rstride0 = rstride[0];
  sstride0 = sstride[0];
  hstride0 = hstride[0];
  bstride0 = bstride[0];
  rptr = ret->data;
  sptr = array->data;
  hptr = h->data;
  if (bound)
    bptr = bound->data;
  else
    bptr = zeros;

  while (rptr)
    {
      /* Do the shift for this dimension.  */
      sh = *hptr;
//.........这里部分代码省略.........

void
spread_c4 (gfc_array_c4 *ret, const gfc_array_c4 *source,
		 const index_type along, const index_type pncopies)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type rdelta = 0;
  index_type rrank;
  index_type rs;
  GFC_COMPLEX_4 *rptr;
  GFC_COMPLEX_4 * restrict dest;
  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type srank;
  const GFC_COMPLEX_4 *sptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type n;
  index_type dim;
  index_type ncopies;

  srank = GFC_DESCRIPTOR_RANK(source);

  rrank = srank + 1;
  if (rrank > GFC_MAX_DIMENSIONS)
    runtime_error ("return rank too large in spread()");

  if (along > rrank)
      runtime_error ("dim outside of rank in spread()");

  ncopies = pncopies;

  if (ret->base_addr == NULL)
    {

      size_t ub, stride;

      /* The front end has signalled that we need to populate the
	 return array descriptor.  */
      ret->dtype.rank = rrank;

      dim = 0;
      rs = 1;
      for (n = 0; n < rrank; n++)
	{
	  stride = rs;
	  if (n == along - 1)
	    {
	      ub = ncopies - 1;
	      rdelta = rs;
	      rs *= ncopies;
	    }
	  else
	    {
	      count[dim] = 0;
	      extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
	      sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
	      rstride[dim] = rs;

	      ub = extent[dim] - 1;
	      rs *= extent[dim];
	      dim++;
	    }
	  GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
	}
      ret->offset = 0;

      /* xmallocarray allocates a single byte for zero size.  */
      ret->base_addr = xmallocarray (rs, sizeof(GFC_COMPLEX_4));
      if (rs <= 0)
        return;
    }
  else
    {
      int zero_sized;

      zero_sized = 0;

      dim = 0;
      if (GFC_DESCRIPTOR_RANK(ret) != rrank)
	runtime_error ("rank mismatch in spread()");

      if (unlikely (compile_options.bounds_check))
	{
	  for (n = 0; n < rrank; n++)
	    {
	      index_type ret_extent;

	      ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
	      if (n == along - 1)
		{
		  rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);

		  if (ret_extent != ncopies)
		    runtime_error("Incorrect extent in return value of SPREAD"
				  " intrinsic in dimension %ld: is %ld,"
				  " should be %ld", (long int) n+1,
//.........这里部分代码省略.........

	int blas_limit, blas_call gemm);
export_proto(matmul_c8);

void
matmul_c8 (gfc_array_c8 * const restrict retarray, 
	gfc_array_c8 * const restrict a, gfc_array_c8 * const restrict b, int try_blas,
	int blas_limit, blas_call gemm)
{
  const GFC_COMPLEX_8 * restrict abase;
  const GFC_COMPLEX_8 * restrict bbase;
  GFC_COMPLEX_8 * restrict dest;

  index_type rxstride, rystride, axstride, aystride, bxstride, bystride;
  index_type x, y, n, count, xcount, ycount;

  assert (GFC_DESCRIPTOR_RANK (a) == 2
          || GFC_DESCRIPTOR_RANK (b) == 2);

/* C[xcount,ycount] = A[xcount, count] * B[count,ycount]

   Either A or B (but not both) can be rank 1:

   o One-dimensional argument A is implicitly treated as a row matrix
     dimensioned [1,count], so xcount=1.

   o One-dimensional argument B is implicitly treated as a column matrix
     dimensioned [count, 1], so ycount=1.
  */

  if (retarray->data == NULL)
    {

index_type count_0 (const gfc_array_l1 * array)
{
  const GFC_LOGICAL_1 * restrict base;
  index_type rank;
  int kind;
  int continue_loop;
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type result;
  index_type n;

  rank = GFC_DESCRIPTOR_RANK (array);
  kind = GFC_DESCRIPTOR_SIZE (array);

  base = array->base_addr;

  if (kind == 1 || kind == 2 || kind == 4 || kind == 8
#ifdef HAVE_GFC_LOGICAL_16
      || kind == 16
#endif
    )
    {
      if (base)
	base = GFOR_POINTER_TO_L1 (base, kind);
    }
  else
    internal_error (NULL, "Funny sized logical array in count_0");

  for (n = 0; n < rank; n++)
    {
      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
      count[n] = 0;

      if (extent[n] <= 0)
	return 0;
    }

  result = 0;
  continue_loop = 1;
  while (continue_loop)
    {
      if (*base)
	result ++;

      count[0]++;
      base += sstride[0];
      n = 0;
      while (count[n] == extent[n])
	{
	  count[n] = 0;
	  base -= sstride[n] * extent[n];
	  n++;
	  if (n == rank)
	    {
	      continue_loop = 0;
	      break;
	    }
	  else
	    {
	      count[n]++;
	      base += sstride[n];
	    }
	}
    }
  return result;
}

GFC_INTEGER_8 *
internal_pack_8 (gfc_array_i8 * source)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type stride[GFC_MAX_DIMENSIONS];
  index_type stride0;
  index_type dim;
  index_type ssize;
  const GFC_INTEGER_8 *src;
  GFC_INTEGER_8 * restrict dest;
  GFC_INTEGER_8 *destptr;
  int packed;

  /* TODO: Investigate how we can figure out if this is a temporary
     since the stride=0 thing has been removed from the frontend.  */

  dim = GFC_DESCRIPTOR_RANK (source);
  ssize = 1;
  packed = 1;
  for (index_type n = 0; n < dim; n++)
    {
      count[n] = 0;
      stride[n] = GFC_DESCRIPTOR_STRIDE(source,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(source,n);
      if (extent[n] <= 0)
        {
          /* Do nothing.  */
          packed = 1;
          break;
        }

      if (ssize != stride[n])
        packed = 0;

      ssize *= extent[n];
    }

  if (packed)
    return source->base_addr;

  /* Allocate storage for the destination.  */
  destptr = xmallocarray (ssize, sizeof (GFC_INTEGER_8));
  dest = destptr;
  src = source->base_addr;
  stride0 = stride[0];


  while (src)
    {
      /* Copy the data.  */
      *(dest++) = *src;
      /* Advance to the next element.  */
      src += stride0;
      count[0]++;
      /* Advance to the next source element.  */
      index_type 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.  */
          src -= stride[n] * extent[n];
          n++;
          if (n == dim)
            {
              src = NULL;
              break;
            }
          else
            {
              count[n]++;
              src += stride[n];
            }
        }
    }
  return destptr;
}

void
msum_c8 (gfc_array_c8 * retarray, gfc_array_c8 * 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_COMPLEX_8 *dest;
  GFC_COMPLEX_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;

  /* 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_COMPLEX_8)
		 		 * 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));
    }

//.........这里部分代码省略.........

void
all_l4 (gfc_array_l4 *retarray, gfc_array_l4 *array, index_type *pdim)
{
    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_LOGICAL_4 *base;
    GFC_LOGICAL_4 *dest;
    index_type rank;
    index_type n;
    index_type len;
    index_type delta;
    index_type dim;

    /* Make dim zero based to avoid confusion.  */
    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;

    len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
    delta = array->dim[dim].stride;

    for (n = 0; n < dim; n++)
    {
        sstride[n] = array->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;
        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_LOGICAL_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)
            len = 0;
    }

    base = array->data;
    dest = retarray->data;

    while (base)
    {
        GFC_LOGICAL_4 *src;
        GFC_LOGICAL_4 result;
        src = base;
        {

            /* Return true only if all the elements are set.  */
            result = 1;
            if (len <= 0)
                *dest = 1;
            else
            {
                for (n = 0; n < len; n++, src += delta)
                {

                    if (! *src)
                    {
                        result = 0;
                        break;
                    }
                }
//.........这里部分代码省略.........

void *
internal_pack (gfc_array_char * source)
{
  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type stride[GFC_MAX_DIMENSIONS];
  index_type stride0;
  index_type dim;
  index_type ssize;
  const char *src;
  char *dest;
  void *destptr;
  int n;
  int packed;
  index_type size;
  int type;

  if (source->dim[0].stride == 0)
    {
      source->dim[0].stride = 1;
      return source->data;
    }

  type = GFC_DESCRIPTOR_TYPE (source);
  size = GFC_DESCRIPTOR_SIZE (source);
  switch (type)
    {
    case GFC_DTYPE_INTEGER:
    case GFC_DTYPE_LOGICAL:
    case GFC_DTYPE_REAL:
      switch (size)
	{
	case 4:
	  return internal_pack_4 ((gfc_array_i4 *)source);
	  
	case 8:
	  return internal_pack_8 ((gfc_array_i8 *)source);
	}
      break;

    case GFC_DTYPE_COMPLEX:
      switch (size)
	{
	case 8:
	  return internal_pack_c4 ((gfc_array_c4 *)source);
	  
	case 16:
	  return internal_pack_c8 ((gfc_array_c8 *)source);
	}
      break;

    default:
      break;
    }

  dim = GFC_DESCRIPTOR_RANK (source);
  ssize = 1;
  packed = 1;
  for (n = 0; n < dim; n++)
    {
      count[n] = 0;
      stride[n] = source->dim[n].stride;
      extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
      if (extent[n] <= 0)
        {
          /* Do nothing.  */
          packed = 1;
          break;
        }

      if (ssize != stride[n])
        packed = 0;

      ssize *= extent[n];
    }

  if (packed)
    return source->data;

   /* Allocate storage for the destination.  */
  destptr = internal_malloc_size (ssize * size);
  dest = (char *)destptr;
  src = source->data;
  stride0 = stride[0] * size;

  while (src)
    {
      /* Copy the data.  */
      memcpy(dest, src, size);
      /* Advance to the next element.  */
      dest += size;
      src += stride0;
      count[0]++;
      /* Advance to the next source element.  */
      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;
//.........这里部分代码省略.........

//.........这里部分代码省略.........
      if (GFC_UNALIGNED_2(d->base_addr) || GFC_UNALIGNED_2(s))
	break;
      else
	{
	  internal_unpack_2 ((gfc_array_i2 *) d, (const GFC_INTEGER_2 *) s);
	  return;
	}
    case GFC_DTYPE_DERIVED_4:
      if (GFC_UNALIGNED_4(d->base_addr) || GFC_UNALIGNED_4(s))
	break;
      else
	{
	  internal_unpack_4 ((gfc_array_i4 *) d, (const GFC_INTEGER_4 *) s);
	  return;
	}

    case GFC_DTYPE_DERIVED_8:
      if (GFC_UNALIGNED_8(d->base_addr) || GFC_UNALIGNED_8(s))
	break;
      else
	{
	  internal_unpack_8 ((gfc_array_i8 *) d, (const GFC_INTEGER_8 *) s);
	  return;
	}

#ifdef HAVE_GFC_INTEGER_16
    case GFC_DTYPE_DERIVED_16:
      if (GFC_UNALIGNED_16(d->base_addr) || GFC_UNALIGNED_16(s))
	break;
      else
	{
	  internal_unpack_16 ((gfc_array_i16 *) d, (const GFC_INTEGER_16 *) s);
	  return;
	}
#endif

    default:
      break;
    }

  size = GFC_DESCRIPTOR_SIZE (d);

  dim = GFC_DESCRIPTOR_RANK (d);
  dsize = 1;
  for (n = 0; n < dim; n++)
    {
      count[n] = 0;
      stride[n] = GFC_DESCRIPTOR_STRIDE(d,n);
      extent[n] = GFC_DESCRIPTOR_EXTENT(d,n);
      if (extent[n] <= 0)
	return;

      if (dsize == stride[n])
	dsize *= extent[n];
      else
	dsize = 0;
    }

  src = s;

  if (dsize != 0)
    {
      memcpy (dest, src, dsize * size);
      return;
    }

  stride0 = stride[0] * size;

  while (dest)
    {
      /* Copy the data.  */
      memcpy (dest, src, size);
      /* Advance to the next element.  */
      src += size;
      dest += stride0;
      count[0]++;
      /* Advance to the next source element.  */
      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 -= stride[n] * extent[n] * size;
          n++;
          if (n == dim)
            {
              dest = NULL;
              break;
            }
          else
            {
              count[n]++;
              dest += stride[n] * size;
            }
        }
    }
}

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;
//.........这里部分代码省略.........

void
transpose_c4 (gfc_array_c4 * ret, gfc_array_c4 * source)
{
  /* r.* indicates the return array.  */
  index_type rxstride, rystride;
  GFC_COMPLEX_4 *rptr;
  /* s.* indicates the source array.  */
  index_type sxstride, systride;
  const GFC_COMPLEX_4 *sptr;

  index_type xcount, ycount;
  index_type x, y;

  assert (GFC_DESCRIPTOR_RANK (source) == 2);

  if (ret->data == NULL)
    {
      assert (GFC_DESCRIPTOR_RANK (ret) == 2);
      assert (ret->dtype == source->dtype);

      ret->dim[0].lbound = 0;
      ret->dim[0].ubound = source->dim[1].ubound - source->dim[1].lbound;
      ret->dim[0].stride = 1;

      ret->dim[1].lbound = 0;
      ret->dim[1].ubound = source->dim[0].ubound - source->dim[0].lbound;
      ret->dim[1].stride = ret->dim[0].ubound+1;

      ret->data = internal_malloc_size (sizeof (GFC_COMPLEX_4) * size0 ((array_t *) ret));
      ret->offset = 0;
    }

  if (ret->dim[0].stride == 0)
    ret->dim[0].stride = 1;
  if (source->dim[0].stride == 0)
    source->dim[0].stride = 1;

  sxstride = source->dim[0].stride;
  systride = source->dim[1].stride;
  xcount = source->dim[0].ubound + 1 - source->dim[0].lbound;
  ycount = source->dim[1].ubound + 1 - source->dim[1].lbound;

  rxstride = ret->dim[0].stride;
  rystride = ret->dim[1].stride;

  rptr = ret->data;
  sptr = source->data;

  for (y=0; y < ycount; y++)
    {
      for (x=0; x < xcount; x++)
        {
          *rptr = *sptr;

          sptr += sxstride;
          rptr += rystride;
        }
        sptr += systride - (sxstride * xcount);
        rptr += rxstride - (rystride * xcount);
    }
}

static void
transpose_internal (gfc_array_char *ret, gfc_array_char *source,
		    index_type size)
{
  /* r.* indicates the return array.  */
  index_type rxstride, rystride;
  char *rptr;
  /* s.* indicates the source array.  */
  index_type sxstride, systride;
  const char *sptr;

  index_type xcount, ycount;
  index_type x, y;

  assert (GFC_DESCRIPTOR_RANK (source) == 2
          && GFC_DESCRIPTOR_RANK (ret) == 2);

  if (ret->data == NULL)
    {
      assert (ret->dtype == source->dtype);

      ret->dim[0].lbound = 0;
      ret->dim[0].ubound = source->dim[1].ubound - source->dim[1].lbound;
      ret->dim[0].stride = 1;

      ret->dim[1].lbound = 0;
      ret->dim[1].ubound = source->dim[0].ubound - source->dim[0].lbound;
      ret->dim[1].stride = ret->dim[0].ubound+1;

      ret->data = internal_malloc_size (size * size0 ((array_t*)ret));
      ret->offset = 0;
    }
  else if (unlikely (compile_options.bounds_check))
    {
      index_type ret_extent, src_extent;

      ret_extent = ret->dim[0].ubound + 1 - ret->dim[0].lbound;
      src_extent = source->dim[1].ubound + 1 - source->dim[1].lbound;

      if (src_extent != ret_extent)
	runtime_error ("Incorrect extent in return value of TRANSPOSE"
		       " intrinsic in dimension 1: is %ld,"
		       " should be %ld", (long int) src_extent,
		       (long int) ret_extent);

      ret_extent = ret->dim[1].ubound + 1 - ret->dim[1].lbound;
      src_extent = source->dim[0].ubound + 1 - source->dim[0].lbound;

      if (src_extent != ret_extent)
	runtime_error ("Incorrect extent in return value of TRANSPOSE"
		       " intrinsic in dimension 2: is %ld,"
		       " should be %ld", (long int) src_extent,
		       (long int) ret_extent);

    }

  sxstride = source->dim[0].stride * size;
  systride = source->dim[1].stride * size;
  xcount = source->dim[0].ubound + 1 - source->dim[0].lbound;
  ycount = source->dim[1].ubound + 1 - source->dim[1].lbound;

  rxstride = ret->dim[0].stride * size;
  rystride = ret->dim[1].stride * size;

  rptr = ret->data;
  sptr = source->data;

  for (y = 0; y < ycount; y++)
    {
      for (x = 0; x < xcount; x++)
        {
          memcpy (rptr, sptr, size);

          sptr += sxstride;
          rptr += rystride;
        }
      sptr += systride - (sxstride * xcount);
      rptr += rxstride - (rystride * xcount);
    }
}

void
cshift0_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, ptrdiff_t shift,
		     int which)
{
  /* r.* indicates the return array.  */
  index_type rstride[GFC_MAX_DIMENSIONS];
  index_type rstride0;
  index_type roffset;
  GFC_INTEGER_8 *rptr;

  /* s.* indicates the source array.  */
  index_type sstride[GFC_MAX_DIMENSIONS];
  index_type sstride0;
  index_type soffset;
  const GFC_INTEGER_8 *sptr;

  index_type count[GFC_MAX_DIMENSIONS];
  index_type extent[GFC_MAX_DIMENSIONS];
  index_type dim;
  index_type len;
  index_type n;

  bool do_blocked;
  index_type r_ex, a_ex;

  which = which - 1;
  sstride[0] = 0;
  rstride[0] = 0;

  extent[0] = 1;
  count[0] = 0;
  n = 0;
  /* Initialized for avoiding compiler warnings.  */
  roffset = 1;
  soffset = 1;
  len = 0;

  r_ex = 1;
  a_ex = 1;

  if (which > 0)
    {
      /* Test if both ret and array are contiguous.  */
      do_blocked = true;
      dim = GFC_DESCRIPTOR_RANK (array);
      for (n = 0; n < dim; n ++)
	{
	  index_type rs, as;
	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
	  if (rs != r_ex)
	    {
	      do_blocked = false;
	      break;
	    }
	  as = GFC_DESCRIPTOR_STRIDE (array, n);
	  if (as != a_ex)
	    {
	      do_blocked = false;
	      break;
	    }
	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
	  a_ex *= GFC_DESCRIPTOR_EXTENT (array, n);
	}
    }
  else
    do_blocked = false;

  n = 0;

  if (do_blocked)
    {
      /* For contiguous arrays, use the relationship that

         dimension(n1,n2,n3) :: a, b
	 b = cshift(a,sh,3)

         can be dealt with as if

	 dimension(n1*n2*n3) :: an, bn
	 bn = cshift(a,sh*n1*n2,1)

	 we can used a more blocked algorithm for dim>1.  */
      sstride[0] = 1;
      rstride[0] = 1;
      roffset = 1;
      soffset = 1;
      len = GFC_DESCRIPTOR_STRIDE(array, which)
	* GFC_DESCRIPTOR_EXTENT(array, which);      
      shift *= GFC_DESCRIPTOR_STRIDE(array, which);
      for (dim = which + 1; dim < GFC_DESCRIPTOR_RANK (array); dim++)
	{
	  count[n] = 0;
	  extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
	  rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
	  sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
	  n++;
	}
      dim = GFC_DESCRIPTOR_RANK (array) - which;
    }
  else
//.........这里部分代码省略.........

void
maxloc0_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 *array)
{
    index_type count[GFC_MAX_DIMENSIONS];
    index_type extent[GFC_MAX_DIMENSIONS];
    index_type sstride[GFC_MAX_DIMENSIONS];
    index_type dstride;
    GFC_REAL_8 *base;
    GFC_INTEGER_8 *dest;
    index_type rank;
    index_type n;

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

    if (retarray->data == NULL)
    {
        retarray->dim[0].lbound = 0;
        retarray->dim[0].ubound = rank-1;
        retarray->dim[0].stride = 1;
        retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
        retarray->base = 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;

    dstride = retarray->dim[0].stride;
    dest = retarray->data;
    for (n = 0; n < rank; n++)
    {
        sstride[n] = array->dim[n].stride;
        extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
        count[n] = 0;
        if (extent[n] <= 0)
        {
            /* Set the return value.  */
            for (n = 0; n < rank; n++)
                dest[n * dstride] = 0;
            return;
        }
    }

    base = array->data;

    /* Initialize the return value.  */
    for (n = 0; n < rank; n++)
        dest[n * dstride] = 1;
    {

        GFC_REAL_8 maxval;

        maxval = -GFC_REAL_8_HUGE;

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

                if (*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];
            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];
                n++;
                if (n == rank)
                {
                    /* Break out of the loop.  */
                    base = NULL;
                    break;
//.........这里部分代码省略.........

void
transpose_i8 (gfc_array_i8 * const restrict ret, 
	gfc_array_i8 * const restrict source)
{
  /* r.* indicates the return array.  */
  index_type rxstride, rystride;
  GFC_INTEGER_8 * restrict rptr;
  /* s.* indicates the source array.  */
  index_type sxstride, systride;
  const GFC_INTEGER_8 *sptr;

  index_type xcount, ycount;
  index_type x, y;

  assert (GFC_DESCRIPTOR_RANK (source) == 2);

  if (ret->base_addr == NULL)
    {
      assert (GFC_DESCRIPTOR_RANK (ret) == 2);
      assert (ret->dtype == source->dtype);

      GFC_DIMENSION_SET(ret->dim[0], 0, GFC_DESCRIPTOR_EXTENT(source,1) - 1,
			1);

      GFC_DIMENSION_SET(ret->dim[1], 0, GFC_DESCRIPTOR_EXTENT(source,0) - 1,
			GFC_DESCRIPTOR_EXTENT(source, 1));

      ret->base_addr = xmallocarray (size0 ((array_t *) ret), 
                                     sizeof (GFC_INTEGER_8));
      ret->offset = 0;