blob: b13456925f7c846fdb18a0a5f1d1a858c20fe7c8 [file] [log] [blame]
 ! { dg-do run } ! Test CSHIFT with array argument for shift module rnd implicit none contains subroutine fill(a,n) integer, intent(out), dimension(:,:) :: a integer, intent(in) :: n real, dimension(size(a,1),size(a,2)) :: r call random_number(r) a = int(2*n*r-n) end subroutine fill end module rnd module csh implicit none contains subroutine emul_cshift(a,sh_in,dim, c) integer, dimension(:,:,:), intent(in) :: a integer, dimension(:,:,:), intent(out) :: c integer, dimension(:,:), intent(in) :: sh_in integer, intent(in) :: dim integer :: sh, rsh integer :: s1, s2, s3, n, i integer :: n1, n2, n3 n1 = size(a,1) n2 = size(a,2) n3 = size(a,3) if (dim == 1) then n = n1 do s2=1,n2 do s3=1,n3 sh = modulo(sh_in(s2,s3), n) rsh = n - sh do i=1,rsh c(i,s2,s3) = a(i+sh,s2,s3) end do do i=rsh+1,n c(i,s2,s3) = a(i-rsh,s2,s3) end do end do end do else if (dim == 2) then n = n2 do s3=1,n3 do s1=1,n1 sh = modulo(sh_in(s1,s3),n) rsh = n - sh do i=1,rsh c(s1,i,s3) = a(s1,i+sh,s3) end do do i=rsh+1,n c(s1,i,s3) = a(s1,i-rsh,s3) end do end do end do else if (dim == 3) then n = n3 do s2=1,n2 do s1=1,n1 sh = modulo(sh_in(s1,s2),n) rsh = n - sh do i=1,rsh c(s1,s2,i) = a(s1,s2,i+sh) end do do i=rsh+1,n c(s1,s2,i) = a(s1,s2,i-rsh) end do end do end do else stop "Illegal dim" end if end subroutine emul_cshift end module csh program main use csh use rnd implicit none integer, parameter :: n1=30,n2=40,n3=50 integer, dimension(n1,n2,n3) :: a, b,c integer :: s1, s2, s3 integer :: dim integer, dimension(:,:), allocatable :: sh1, sh2, sh3 integer, dimension(:), allocatable :: sh_shift integer :: sh, rsh integer :: i,j,k,v type t integer :: i1, i2, i3 end type t type(t), dimension(n1,n2,n3) :: ta, tb v = 1 do k=1,n3 do j=1,n2 do i=1,n1 a(i,j,k) = v v = v + 1 end do end do end do ta%i1 = a ta%i2 = a+a ta%i3 = a+a+a allocate(sh1(n2,n3)) allocate(sh2(n1,n3)) allocate(sh3(n1,n2)) call fill(sh1,10) call fill(sh2,10) call fill(sh3,10) b = cshift(a,sh1,1) call emul_cshift(a,sh1,1,c) if (any(b /= c)) then print *,b print *,c STOP 1 end if tb = cshift(ta,sh1,1) if (any(tb%i1 /= c)) STOP 2 b = cshift(a,sh2,2) call emul_cshift(a,sh2,2,c) if (any(b /= c)) STOP 3 tb = cshift(ta,sh2,2) if (any (tb%i2 /= c*2)) STOP 4 b = cshift(a,sh3,3) call emul_cshift(a,sh3,3,c) if (any(b /= c)) STOP 5 tb = cshift(ta,sh3,3) if (any(tb%i3 /= c*3)) STOP 6 b = -42 c = -42 b(1:n1:2,:,:) = cshift(a(1:n1/2,:,:),sh1,1) call emul_cshift(a(1:n1/2,:,:), sh1, 1, c(1:n1:2,:,:)) if (any(b /= c)) STOP 7 tb%i1 = -42 tb%i2 = -2*42 tb%i3 = -3*42 tb(1:n1:2,:,:) = cshift(ta(1:n1/2,:,:),sh1,1) if (any(tb%i1 /= b)) STOP 8 if (any(tb%i2 /= 2*b)) STOP 9 if (any(tb%i3 /= 3*b)) STOP 10 9000 format (99(3(I3,1X),2X)) end program main