re PR fortran/52473 (CSHIFT slow - inline it?)

2017-06-18  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/52473
	* m4/cshift0.m4:  For arrays that are contiguous up to
	shift, implement blocked algorighm for cshift.
	* generated/cshift0_c10.c:  Regenerated.
	* generated/cshift0_c16.c:  Regenerated.
	* generated/cshift0_c4.c:  Regenerated.
	* generated/cshift0_c8.c:  Regenerated.
	* generated/cshift0_i1.c:  Regenerated.
	* generated/cshift0_i16.c:  Regenerated.
	* generated/cshift0_i2.c:  Regenerated.
	* generated/cshift0_i4.c:  Regenerated.
	* generated/cshift0_i8.c:  Regenerated.
	* generated/cshift0_r10.c:  Regenerated.
	* generated/cshift0_r16.c:  Regenerated.
	* generated/cshift0_r4.c:  Regenerated.
	* generated/cshift0_r8.c:  Regenerated.

2017-06-18  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/52473
	* gfortran.dg/cshift_1.f90:  New test.

From-SVN: r249350

gcc/testsuite/ChangeLog

@@ -1,3 +1,8 @@
+2017-06-18  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/52473
+	* gfortran.dg/cshift_1.f90:  New test.
+
 2017-06-17  Rainer Orth  <ro@CeBiTec.Uni-Bielefeld.DE>
 
 	Remove dg-skip-if, dg-xfail-if, dg-xfail-run-if default args.

gcc/testsuite/gfortran.dg/cshift_1.f90

@@ -0,0 +1,108 @@
+! { dg-do  run }
+! Take cshift through its paces to make sure no boundary
+! cases are wrong.
+
+module kinds
+  integer, parameter :: sp = selected_real_kind(6) ! Single precision
+end module kinds
+
+module replacements
+  use kinds
+contains
+  subroutine cshift_sp_3_v1 (array, shift, dim, res)
+    integer, parameter :: wp = sp
+    real(kind=wp), dimension(:,:,:), intent(in) :: array
+    integer, intent(in) :: shift, dim
+    real(kind=wp), dimension(:,:,:), intent(out) :: res
+    integer :: i,j,k
+    integer :: sh, rsh
+    integer :: n
+    integer :: n2, n3
+    res = 0
+    n3 = size(array,3)
+    n2 = size(array,2)
+    n1 = size(array,1)
+    if (dim == 1) then
+       n = n1
+       sh = modulo(shift, n)
+       rsh = n - sh
+       do k=1, n3
+          do j=1, n2
+             do i=1, rsh
+                res(i,j,k) = array(i+sh,j,k)
+             end do
+             do i=rsh+1,n
+                res(i,j,k) = array(i-rsh,j,k)
+             end do
+          end do
+       end do
+    else if (dim == 2) then
+       n = n2
+       sh = modulo(shift,n)
+       rsh = n - sh
+       do k=1, n3
+          do j=1, rsh
+             do i=1, n1
+                res(i,j,k) = array(i,j+sh, k)
+             end do
+          end do
+          do j=rsh+1, n
+             do i=1, n1
+                res(i,j,k) = array(i,j-rsh, k)
+             end do
+          end do
+       end do
+    else if (dim == 3) then
+       n = n3
+       sh = modulo(shift, n)
+       rsh = n - sh
+       do k=1, rsh
+          do j=1, n2
+             do i=1, n1
+                res(i,j,k) = array(i, j, k+sh)
+             end do
+          end do
+       end do
+       do k=rsh+1, n
+          do j=1, n2
+             do i=1, n1
+                res(i,j, k) = array(i, j, k-rsh)
+             end do
+          end do          
+       end do
+    else
+       stop "Wrong argument to dim"
+    end if
+  end subroutine cshift_sp_3_v1
+end module replacements
+
+program testme
+  use kinds
+  use replacements
+  implicit none
+  integer, parameter :: wp = sp  ! Working precision
+  INTEGER, PARAMETER :: n = 7
+  real(kind=wp), dimension(:,:,:), allocatable :: a,b,c
+  integer i, j, k
+  real:: t1, t2
+  integer, parameter :: nrep = 20
+
+  allocate (a(n,n,n), b(n,n,n),c(n,n,n))
+  call random_number(a)
+  do k = 1,3
+   do i=-3,3,2
+     call cshift_sp_3_v1 (a, i, k, b)
+     c = cshift(a,i,k)
+     if (any (c /= b)) call abort
+   end do
+  end do
+  deallocate (b,c)
+  allocate (b(n-1,n-1,n-1),c(n-1,n-1,n-1))
+  do k=1,3
+     do i=-3,3,2
+        call cshift_sp_3_v1 (a(1:n-1,1:n-1,1:n-1), i, k, b)
+        c = cshift(a(1:n-1,1:n-1,1:n-1), i, k)
+        if (any (c /= b)) call abort
+     end do
+  end do
+end program testme

libgfortran/ChangeLog

@@ -1,3 +1,22 @@
+2017-06-18  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/52473
+	* m4/cshift0.m4:  For arrays that are contiguous up to
+	shift, implement blocked algorighm for cshift.
+	* generated/cshift0_c10.c:  Regenerated.
+	* generated/cshift0_c16.c:  Regenerated.
+	* generated/cshift0_c4.c:  Regenerated.
+	* generated/cshift0_c8.c:  Regenerated.
+	* generated/cshift0_i1.c:  Regenerated.
+	* generated/cshift0_i16.c:  Regenerated.
+	* generated/cshift0_i2.c:  Regenerated.
+	* generated/cshift0_i4.c:  Regenerated.
+	* generated/cshift0_i8.c:  Regenerated.
+	* generated/cshift0_r10.c:  Regenerated.
+	* generated/cshift0_r16.c:  Regenerated.
+	* generated/cshift0_r4.c:  Regenerated.
+	* generated/cshift0_r8.c:  Regenerated.
+
 2017-06-06  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/80975

libgfortran/generated/cshift0_c10.c

@@ -51,6 +51,9 @@ cshift0_c10 (gfc_array_c10 *ret, const gfc_array_c10 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_c10 (gfc_array_c10 *ret, const gfc_array_c10 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_c16.c

@@ -51,6 +51,9 @@ cshift0_c16 (gfc_array_c16 *ret, const gfc_array_c16 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_c16 (gfc_array_c16 *ret, const gfc_array_c16 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_c4.c

@@ -51,6 +51,9 @@ cshift0_c4 (gfc_array_c4 *ret, const gfc_array_c4 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_c4 (gfc_array_c4 *ret, const gfc_array_c4 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_c8.c

@@ -51,6 +51,9 @@ cshift0_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_c8 (gfc_array_c8 *ret, const gfc_array_c8 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_i1.c

@@ -51,6 +51,9 @@ cshift0_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_i1 (gfc_array_i1 *ret, const gfc_array_i1 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_i16.c

@@ -51,6 +51,9 @@ cshift0_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_i16 (gfc_array_i16 *ret, const gfc_array_i16 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_i2.c

@@ -51,6 +51,9 @@ cshift0_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_i2 (gfc_array_i2 *ret, const gfc_array_i2 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_i4.c

@@ -51,6 +51,9 @@ cshift0_i4 (gfc_array_i4 *ret, const gfc_array_i4 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_i4 (gfc_array_i4 *ret, const gfc_array_i4 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_i8.c

@@ -51,6 +51,9 @@ cshift0_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_i8 (gfc_array_i8 *ret, const gfc_array_i8 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_r10.c

@@ -51,6 +51,9 @@ cshift0_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_r10 (gfc_array_r10 *ret, const gfc_array_r10 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_r16.c

@@ -51,6 +51,9 @@ cshift0_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_r16 (gfc_array_r16 *ret, const gfc_array_r16 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_r4.c

@@ -51,6 +51,9 @@ cshift0_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_r4 (gfc_array_r4 *ret, const gfc_array_r4 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/generated/cshift0_r8.c

@@ -51,6 +51,9 @@ cshift0_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -63,33 +66,99 @@ cshift0_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;

libgfortran/m4/cshift0.m4

@@ -52,6 +52,9 @@ cshift0_'rtype_code` ('rtype` *ret, const 'rtype` *array, ptrdiff_t shift,
   index_type len;
   index_type n;
 
+  bool do_blocked;
+  index_type r_ex, a_ex;
+
   which = which - 1;
   sstride[0] = 0;
   rstride[0] = 0;
@@ -64,33 +67,99 @@ cshift0_'rtype_code` ('rtype` *ret, const 'rtype` *array, ptrdiff_t shift,
   soffset = 1;
   len = 0;
 
-  for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
+  r_ex = 1;
-    {
+  a_ex = 1;
-      if (dim == which)
+
-        {
+  if (which > 0)
-          roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
+    {
-          if (roffset == 0)
+      /* Test if both ret and array are contiguous.  */
-            roffset = 1;
+      do_blocked = true;
-          soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
+      dim = GFC_DESCRIPTOR_RANK (array);
-          if (soffset == 0)
+      for (n = 0; n < dim; n ++)
-            soffset = 1;
+	{
-          len = GFC_DESCRIPTOR_EXTENT(array,dim);
+	  index_type rs, as;
-        }
+	  rs = GFC_DESCRIPTOR_STRIDE (ret, n);
-      else
+	  if (rs != r_ex)
-        {
+	    {
-          count[n] = 0;
+	      do_blocked = false;
-          extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
+	      break;
-          rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
+	    }
-          sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
+	  as = GFC_DESCRIPTOR_STRIDE (array, n);
-          n++;
+	  if (as != a_ex)
-        }
+	    {
-    }
+	      do_blocked = false;
-  if (sstride[0] == 0)
+	      break;
-    sstride[0] = 1;
+	    }
-  if (rstride[0] == 0)
+	  r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
-    rstride[0] = 1;
+	  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
+    {
+      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);
+    }
 
-  dim = GFC_DESCRIPTOR_RANK (array);
   rstride0 = rstride[0];
   sstride0 = sstride[0];
   rptr = ret->base_addr;