gcc/testsuite/gfortran.dg/cshift_2.f90

   1 ! { dg-do  run }
   2 ! Test CSHIFT with array argument for shift
   3 module rnd
   4   implicit none
   5 contains
   6   subroutine fill(a,n)
   7     integer, intent(out), dimension(:,:) :: a
   8     integer, intent(in) :: n
   9     real, dimension(size(a,1),size(a,2)) :: r
  10     call random_number(r)
  11     a = int(2*n*r-n)
  12   end subroutine fill
  13 end module rnd
  14
  15 module csh
  16   implicit none
  17 contains
  18   subroutine emul_cshift(a,sh_in,dim, c)
  19     integer, dimension(:,:,:), intent(in) :: a
  20     integer, dimension(:,:,:), intent(out) :: c
  21     integer, dimension(:,:), intent(in) :: sh_in
  22     integer, intent(in) :: dim
  23     integer :: sh, rsh
  24     integer :: s1, s2, s3, n, i
  25     integer :: n1, n2, n3
  26     n1 = size(a,1)
  27     n2 = size(a,2)
  28     n3 = size(a,3)
  29     if (dim == 1) then
  30        n = n1
  31        do s2=1,n2
  32           do s3=1,n3
  33              sh = modulo(sh_in(s2,s3), n)
  34              rsh = n - sh
  35              do i=1,rsh
  36                 c(i,s2,s3) = a(i+sh,s2,s3)
  37              end do
  38              do i=rsh+1,n
  39                 c(i,s2,s3) = a(i-rsh,s2,s3)
  40              end do
  41           end do
  42        end do
  43     else if (dim == 2) then
  44        n = n2
  45        do s3=1,n3
  46           do s1=1,n1
  47              sh = modulo(sh_in(s1,s3),n)
  48              rsh = n - sh
  49              do i=1,rsh
  50                 c(s1,i,s3) = a(s1,i+sh,s3)
  51              end do
  52              do i=rsh+1,n
  53                 c(s1,i,s3) = a(s1,i-rsh,s3)
  54              end do
  55           end do
  56        end do
  57
  58     else if (dim == 3) then
  59        n = n3
  60        do s2=1,n2
  61           do s1=1,n1
  62              sh = modulo(sh_in(s1,s2),n)
  63              rsh = n - sh
  64              do i=1,rsh
  65                 c(s1,s2,i) = a(s1,s2,i+sh)
  66              end do
  67              do i=rsh+1,n
  68                 c(s1,s2,i) = a(s1,s2,i-rsh)
  69              end do
  70           end do
  71        end do
  72     else
  73        stop "Illegal dim"
  74     end if
  75   end subroutine emul_cshift
  76 end module csh
  77 program main
  78   use csh
  79   use rnd
  80   implicit none
  81   integer, parameter :: n1=30,n2=40,n3=50
  82   integer, dimension(n1,n2,n3) :: a, b,c
  83   integer :: s1, s2, s3
  84   integer :: dim
  85   integer, dimension(:,:), allocatable :: sh1, sh2, sh3
  86   integer, dimension(:), allocatable :: sh_shift
  87   integer :: sh, rsh
  88   integer :: i,j,k,v
  89   type t
  90      integer :: i1, i2, i3
  91   end type t
  92   type(t), dimension(n1,n2,n3) :: ta, tb
  93
  94   v = 1
  95   do k=1,n3
  96      do j=1,n2
  97         do i=1,n1
  98            a(i,j,k) = v
  99            v = v + 1
 100         end do
 101      end do
 102   end do
 103
 104   ta%i1 = a
 105   ta%i2 = a+a
 106   ta%i3 = a+a+a
 107   allocate(sh1(n2,n3))
 108   allocate(sh2(n1,n3))
 109   allocate(sh3(n1,n2))
 110
 111   call fill(sh1,10)
 112   call fill(sh2,10)
 113   call fill(sh3,10)
 114
 115   b = cshift(a,sh1,1)
 116   call emul_cshift(a,sh1,1,c)
 117   if (any(b /= c)) then
 118      print *,b
 119      print *,c
 120      call abort
 121   end if
 122   tb = cshift(ta,sh1,1)
 123   if (any(tb%i1 /= c)) call abort
 124
 125   b = cshift(a,sh2,2)
 126   call emul_cshift(a,sh2,2,c)
 127   if (any(b /= c)) call abort
 128   tb = cshift(ta,sh2,2)
 129   if (any (tb%i2 /= c*2)) call abort
 130
 131   b = cshift(a,sh3,3)
 132   call emul_cshift(a,sh3,3,c)
 133   if (any(b /= c)) call abort
 134   tb = cshift(ta,sh3,3)
 135   if (any(tb%i3 /= c*3)) call abort
 136
 137   b = -42
 138   c = -42
 139   b(1:n1:2,:,:) = cshift(a(1:n1/2,:,:),sh1,1)
 140   call emul_cshift(a(1:n1/2,:,:), sh1, 1, c(1:n1:2,:,:))
 141   if (any(b /= c)) call abort
 142
 143   tb%i1 = -42
 144   tb%i2 = -2*42
 145   tb%i3 = -3*42
 146   tb(1:n1:2,:,:) = cshift(ta(1:n1/2,:,:),sh1,1)
 147   if (any(tb%i1 /= b)) call abort
 148   if (any(tb%i2 /= 2*b)) call abort
 149   if (any(tb%i3 /= 3*b)) call abort
 150
 151 9000 format (99(3(I3,1X),2X))
 152 end program main