自学教程：C++ GFC_DESCRIPTOR_RANK函数代码示例

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

voidspread_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);voidmatmul_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;}

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

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

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

voidtranspose_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 voidtranspose_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);    }}

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

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

voidtranspose_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;

voidfstat_i8_sub (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray, GFC_INTEGER_8 *status){  int val;  struct stat sb;  /* If the rank of the array is not 1, abort.  */  if (GFC_DESCRIPTOR_RANK (sarray) != 1)    runtime_error ("Array rank of SARRAY is not 1.");  /* If the array is too small, abort.  */  if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)    runtime_error ("Array size of SARRAY is too small.");  /* Convert Fortran unit number to C file descriptor.  */  val = unit_to_fd ((int) *unit);  if (val >= 0)    val = fstat(val, &sb);  if (val == 0)    {      /* Device ID  */      sarray->data[0] = sb.st_dev;      /* Inode number  */      sarray->data[sarray->dim[0].stride] = sb.st_ino;      /* File mode  */      sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;      /* Number of (hard) links  */      sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;      /* Owner's uid  */      sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;      /* Owner's gid  */      sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;      /* ID of device containing directory entry for file (0 if not available) */#if HAVE_STRUCT_STAT_ST_RDEV      sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;#else      sarray->data[6 * sarray->dim[0].stride] = 0;#endif      /* File size (bytes)  */      sarray->data[7 * sarray->dim[0].stride] = sb.st_size;      /* Last access time  */      sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;      /* Last modification time  */      sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;      /* Last file status change time  */      sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;      /* Preferred I/O block size (-1 if not available)  */#if HAVE_STRUCT_STAT_ST_BLKSIZE      sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;#else      sarray->data[11 * sarray->dim[0].stride] = -1;#endif      /* Number of blocks allocated (-1 if not available)  */#if HAVE_STRUCT_STAT_ST_BLOCKS      sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;#else      sarray->data[12 * sarray->dim[0].stride] = -1;#endif    }  if (status != NULL)    *status = (val == 0) ? 0 : errno;}

voidspread_i1 (gfc_array_i1 *ret, const gfc_array_i1 *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_INTEGER_1 *rptr;  GFC_INTEGER_1 * restrict dest;  /* s.* indicates the source array.  */  index_type sstride[GFC_MAX_DIMENSIONS];  index_type sstride0;  index_type srank;  const GFC_INTEGER_1 *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->data == NULL)    {      /* The front end has signalled that we need to populate the	 return array descriptor.  */      ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;      dim = 0;      rs = 1;      for (n = 0; n < rrank; n++)	{	  ret->dim[n].stride = rs;	  ret->dim[n].lbound = 0;	  if (n == along - 1)	    {	      ret->dim[n].ubound = ncopies - 1;	      rdelta = rs;	      rs *= ncopies;	    }	  else	    {	      count[dim] = 0;	      extent[dim] = source->dim[dim].ubound + 1		- source->dim[dim].lbound;	      sstride[dim] = source->dim[dim].stride;	      rstride[dim] = rs;	      ret->dim[n].ubound = extent[dim]-1;	      rs *= extent[dim];	      dim++;	    }	}      ret->offset = 0;      if (rs > 0)        ret->data = internal_malloc_size (rs * sizeof(GFC_INTEGER_1));      else	{	  ret->data = internal_malloc_size (1);	  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 = ret->dim[n].ubound + 1 - ret->dim[n].lbound;	      if (n == along - 1)		{		  rdelta = ret->dim[n].stride;		  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,				  (long int) ret_extent, (long int) ncopies);//.........这里部分代码省略.........

static voidstat_i4_sub_0 (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,	       gfc_charlen_type name_len, int is_lstat __attribute__ ((unused))){  int val;  char *str;  struct stat sb;  /* If the rank of the array is not 1, abort.  */  if (GFC_DESCRIPTOR_RANK (sarray) != 1)    runtime_error ("Array rank of SARRAY is not 1.");  /* If the array is too small, abort.  */  if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)    runtime_error ("Array size of SARRAY is too small.");  /* Trim trailing spaces from name.  */  while (name_len > 0 && name[name_len - 1] == ' ')    name_len--;  /* Make a null terminated copy of the string.  */  str = gfc_alloca (name_len + 1);  memcpy (str, name, name_len);  str[name_len] = '/0';  /* On platforms that don't provide lstat(), we use stat() instead.  */#ifdef HAVE_LSTAT  if (is_lstat)    val = lstat(str, &sb);  else#endif    val = stat(str, &sb);  if (val == 0)    {      /* Device ID  */      sarray->data[0 * sarray->dim[0].stride] = sb.st_dev;      /* Inode number  */      sarray->data[1 * sarray->dim[0].stride] = sb.st_ino;      /* File mode  */      sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;      /* Number of (hard) links  */      sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;      /* Owner's uid  */      sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;      /* Owner's gid  */      sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;      /* ID of device containing directory entry for file (0 if not available) */#if HAVE_STRUCT_STAT_ST_RDEV      sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;#else      sarray->data[6 * sarray->dim[0].stride] = 0;#endif      /* File size (bytes)  */      sarray->data[7 * sarray->dim[0].stride] = sb.st_size;      /* Last access time  */      sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;      /* Last modification time  */      sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;      /* Last file status change time  */      sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;      /* Preferred I/O block size (-1 if not available)  */#if HAVE_STRUCT_STAT_ST_BLKSIZE      sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;#else      sarray->data[11 * sarray->dim[0].stride] = -1;#endif      /* Number of blocks allocated (-1 if not available)  */#if HAVE_STRUCT_STAT_ST_BLOCKS      sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;#else      sarray->data[12 * sarray->dim[0].stride] = -1;#endif    }  if (status != NULL)    *status = (val == 0) ? 0 : errno;}

voidunpack0_i8 (gfc_array_i8 *ret, const gfc_array_i8 *vector,		 const gfc_array_l1 *mask, const GFC_INTEGER_8 *fptr){  /* r.* indicates the return array.  */  index_type rstride[GFC_MAX_DIMENSIONS];  index_type rstride0;  index_type rs;  GFC_INTEGER_8 * restrict rptr;  /* v.* indicates the vector array.  */  index_type vstride0;  GFC_INTEGER_8 *vptr;  /* Value for field, this is constant.  */  const GFC_INTEGER_8 fval = *fptr;  /* m.* indicates the mask array.  */  index_type mstride[GFC_MAX_DIMENSIONS];  index_type mstride0;  const GFC_LOGICAL_1 *mptr;  index_type count[GFC_MAX_DIMENSIONS];  index_type extent[GFC_MAX_DIMENSIONS];  index_type n;  index_type dim;  int empty;  int mask_kind;  empty = 0;  mptr = mask->base_addr;  /* Use the same loop for all logical types, by using GFC_LOGICAL_1     and using shifting to address size and endian issues.  */  mask_kind = GFC_DESCRIPTOR_SIZE (mask);  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8#ifdef HAVE_GFC_LOGICAL_16      || mask_kind == 16#endif      )    {      /*  Do not convert a NULL pointer as we use test for NULL below.  */      if (mptr)	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);    }  else    runtime_error ("Funny sized logical array");  if (ret->base_addr == 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;	  GFC_DIMENSION_SET(ret->dim[n], 0,			    GFC_DESCRIPTOR_EXTENT(mask,n) - 1, rs);	  extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);	  empty = empty || extent[n] <= 0;	  rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);	  mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);	  rs *= extent[n];	}      ret->offset = 0;      ret->base_addr = xmallocarray (rs, sizeof (GFC_INTEGER_8));    }  else    {      dim = GFC_DESCRIPTOR_RANK (ret);      for (n = 0; n < dim; n++)	{	  count[n] = 0;	  extent[n] = GFC_DESCRIPTOR_EXTENT(ret,n);	  empty = empty || extent[n] <= 0;	  rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,n);	  mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);	}      if (rstride[0] == 0)	rstride[0] = 1;    }  if (empty)    return;  if (mstride[0] == 0)    mstride[0] = 1;  vstride0 = GFC_DESCRIPTOR_STRIDE(vector,0);  if (vstride0 == 0)    vstride0 = 1;  rstride0 = rstride[0];  mstride0 = mstride[0];  rptr = ret->base_addr;  vptr = vector->base_addr;  while (rptr)    {//.........这里部分代码省略.........

static voidpack_s_internal (gfc_array_char *ret, const gfc_array_char *array,		 const GFC_LOGICAL_4 *mask, const gfc_array_char *vector,		 index_type size){  /* r.* indicates the return array.  */  index_type rstride0;  char *rptr;  /* s.* indicates the source array.  */  index_type sstride[GFC_MAX_DIMENSIONS];  index_type sstride0;  const char *sptr;  index_type count[GFC_MAX_DIMENSIONS];  index_type extent[GFC_MAX_DIMENSIONS];  index_type n;  index_type dim;  index_type ssize;  index_type nelem;  index_type total;  dim = GFC_DESCRIPTOR_RANK (array);  /* Initialize sstride[0] to avoid -Wmaybe-uninitialized     complaints.  */  sstride[0] = size;  ssize = 1;  for (n = 0; n < dim; n++)    {      count[n] = 0;      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);      if (extent[n] < 0)	extent[n] = 0;      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);      ssize *= extent[n];    }  if (sstride[0] == 0)    sstride[0] = size;  sstride0 = sstride[0];  if (ssize != 0)    sptr = array->base_addr;  else    sptr = NULL;  if (ret->base_addr == NULL)    {      /* Allocate the memory for the result.  */      if (vector != NULL)	{	  /* The return array will have as many elements as there are	     in vector.  */	  total = GFC_DESCRIPTOR_EXTENT(vector,0);	  if (total <= 0)	    {	      total = 0;	      vector = NULL;	    }	}      else	{	  if (*mask)	    {	      /* The result array will have as many elements as the input		 array.  */	      total = extent[0];	      for (n = 1; n < dim; n++)		total *= extent[n];	    }	  else	    /* The result array will be empty.  */	    total = 0;	}      /* Setup the array descriptor.  */      GFC_DIMENSION_SET(ret->dim[0],0,total-1,1);      ret->offset = 0;      ret->base_addr = xmallocarray (total, size);      if (total == 0)	return;    }  rstride0 = GFC_DESCRIPTOR_STRIDE_BYTES(ret,0);  if (rstride0 == 0)    rstride0 = size;  rptr = ret->base_addr;  /* The remaining possibilities are now:       If MASK is .TRUE., we have to copy the source array into the     result array. We then have to fill it up with elements from VECTOR.       If MASK is .FALSE., we have to copy VECTOR into the result     array. If VECTOR were not present we would have already returned.  */  if (*mask && ssize != 0)    {//.........这里部分代码省略.........

voidcshift0_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, ptrdiff_t shift,		     int which){  /* r.* indicates the return array.  */  index_type rstride[GFC_MAX_DIMENSIONS];  index_type rstride0;  index_type roffset;  GFC_REAL_8 *rptr;  /* s.* indicates the source array.  */  index_type sstride[GFC_MAX_DIMENSIONS];  index_type sstride0;  index_type soffset;  const GFC_REAL_8 *sptr;  index_type count[GFC_MAX_DIMENSIONS];  index_type extent[GFC_MAX_DIMENSIONS];  index_type dim;  index_type len;  index_type n;  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;  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)    {      if (dim == which)        {          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);          if (roffset == 0)            roffset = 1;          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);          if (soffset == 0)            soffset = 1;          len = GFC_DESCRIPTOR_EXTENT(array,dim);        }      else        {          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++;        }    }  if (sstride[0] == 0)    sstride[0] = 1;  if (rstride[0] == 0)    rstride[0] = 1;  dim = GFC_DESCRIPTOR_RANK (array);  rstride0 = rstride[0];  sstride0 = sstride[0];  rptr = ret->base_addr;  sptr = array->base_addr;  /* Avoid the costly modulo for trivially in-bound shifts.  */  if (shift < 0 || shift >= len)    {      shift = len == 0 ? 0 : shift % (ptrdiff_t)len;      if (shift < 0)	shift += len;    }  while (rptr)    {      /* Do the shift for this dimension.  */      /* If elements are contiguous, perform the operation	 in two block moves.  */      if (soffset == 1 && roffset == 1)	{	  size_t len1 = shift * sizeof (GFC_REAL_8);	  size_t len2 = (len - shift) * sizeof (GFC_REAL_8);	  memcpy (rptr, sptr + shift, len2);	  memcpy (rptr + (len - shift), sptr, len1);	}      else	{	  /* Otherwise, we will have to perform the copy one element at	     a time.  */	  GFC_REAL_8 *dest = rptr;	  const GFC_REAL_8 *src = &sptr[shift * soffset];	  for (n = 0; n < len - shift; n++)	    {	      *dest = *src;	      dest += roffset;	      src += soffset;	    }//.........这里部分代码省略.........

void__mmaxloc1_4_r8 (gfc_array_i4 * 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_4 *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_4 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_4)n + 1;    }              }	    *dest = result;	  }      }      /* Advance to the next element.  */      count[0]++;      base += sstride[0];      mbase += mstride[0];//.........这里部分代码省略.........

voidinternal_unpack_8 (gfc_array_i8 * d, const GFC_INTEGER_8 * src){  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 dsize;  GFC_INTEGER_8 * restrict dest;  int n;  dest = d->data;  if (src == dest || !src)    return;  dim = GFC_DESCRIPTOR_RANK (d);  dsize = 1;  for (n = 0; n < dim; n++)    {      count[n] = 0;      stride[n] = d->dim[n].stride;      extent[n] = d->dim[n].ubound + 1 - d->dim[n].lbound;      if (extent[n] <= 0)	return;      if (dsize == stride[n])	dsize *= extent[n];      else	dsize = 0;    }  if (dsize != 0)    {      memcpy (dest, src, dsize * sizeof (GFC_INTEGER_8));      return;    }  stride0 = stride[0];  while (dest)    {      /* Copy the data.  */      *dest = *(src++);      /* Advance to the next element.  */      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];          n++;          if (n == dim)            {              dest = NULL;              break;            }          else            {              count[n]++;              dest += stride[n];            }        }    }}

void__maxloc1_4_r8 (gfc_array_i4 * retarray, gfc_array_r8 *array, index_type *pdim){  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];  GFC_REAL_8 *base;  GFC_INTEGER_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;  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;  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 (sizeof (GFC_INTEGER_4) *                                         (retarray->dim[rank-1].stride * extent[rank-1]));      retarray->base = 0;    }            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_REAL_8 *src;      GFC_INTEGER_4 result;      src = base;      {  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)	      {  if (*src > maxval)    {      maxval = *src;      result = (GFC_INTEGER_4)n + 1;    }          }	    *dest = result;	  }      }      /* Advance to the next element.  */      count[0]++;      base += sstride[0];      dest += dstride[0];      n = 0;      while (count[n] == extent[n])        {//.........这里部分代码省略.........

voidpack_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array,	       const gfc_array_l1 *mask, const gfc_array_r10 *vector){  /* r.* indicates the return array.  */  index_type rstride0;  GFC_REAL_10 * restrict rptr;  /* s.* indicates the source array.  */  index_type sstride[GFC_MAX_DIMENSIONS];  index_type sstride0;  const GFC_REAL_10 *sptr;  /* m.* indicates the mask array.  */  index_type mstride[GFC_MAX_DIMENSIONS];  index_type mstride0;  const GFC_LOGICAL_1 *mptr;  index_type count[GFC_MAX_DIMENSIONS];  index_type extent[GFC_MAX_DIMENSIONS];  int zero_sized;  index_type n;  index_type dim;  index_type nelem;  index_type total;  int mask_kind;  dim = GFC_DESCRIPTOR_RANK (array);  mptr = mask->base_addr;  /* Use the same loop for all logical types, by using GFC_LOGICAL_1     and using shifting to address size and endian issues.  */  mask_kind = GFC_DESCRIPTOR_SIZE (mask);  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8#ifdef HAVE_GFC_LOGICAL_16      || mask_kind == 16#endif      )    {      /*  Do not convert a NULL pointer as we use test for NULL below.  */      if (mptr)	mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);    }  else    runtime_error ("Funny sized logical array");  zero_sized = 0;  for (n = 0; n < dim; n++)    {      count[n] = 0;      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);      if (extent[n] <= 0)       zero_sized = 1;      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);      mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);    }  if (sstride[0] == 0)    sstride[0] = 1;  if (mstride[0] == 0)    mstride[0] = mask_kind;  if (zero_sized)    sptr = NULL;  else    sptr = array->base_addr;  if (ret->base_addr == NULL || unlikely (compile_options.bounds_check))    {      /* Count the elements, either for allocating memory or	 for bounds checking.  */      if (vector != NULL)	{	  /* The return array will have as many	     elements as there are in VECTOR.  */	  total = GFC_DESCRIPTOR_EXTENT(vector,0);	  if (total < 0)	    {	      total = 0;	      vector = NULL;	    }	}      else        {      	  /* We have to count the true elements in MASK.  */	  total = count_0 (mask);        }      if (ret->base_addr == NULL)	{	  /* Setup the array descriptor.  */	  GFC_DIMENSION_SET(ret->dim[0], 0, total-1, 1);	  ret->offset = 0;	  /* xmallocarray allocates a single byte for zero size.  */	  ret->base_addr = xmallocarray (total, sizeof (GFC_REAL_10));	  if (total == 0)//.........这里部分代码省略.........

  index_type count[GFC_MAX_DIMENSIONS];  index_type extent[GFC_MAX_DIMENSIONS];  index_type sstride[GFC_MAX_DIMENSIONS];  index_type dstride[GFC_MAX_DIMENSIONS];  const GFC_REAL_8 * restrict base;  GFC_REAL_8 * restrict dest;  index_type rank;  index_type n;  index_type len;  index_type delta;  index_type dim;  int continue_loop;  /* Make dim zero based to avoid confusion.  */  dim = (*pdim) - 1;  rank = GFC_DESCRIPTOR_RANK (array) - 1;  len = GFC_DESCRIPTOR_EXTENT(array,dim);  if (len < 0)    len = 0;  delta = GFC_DESCRIPTOR_STRIDE(array,dim);  for (n = 0; n < dim; n++)    {      sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);      if (extent[n] < 0)	extent[n] = 0;    }  for (n = dim; n < rank; n++)

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);  assert (rank > 0);  assert (GFC_DESCRIPTOR_RANK (retarray) == 1);  assert (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound == rank);  if (array->dim[0].stride == 0)    array->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;      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;            }          else            {              count[n]++;              base += sstride[n];            }        }    }  }}