|
111
|
1 ! { dg-do run }
|
|
|
2 ! Take cshift through its paces to make sure no boundary
|
|
|
3 ! cases are wrong.
|
|
|
4
|
|
|
5 module kinds
|
|
|
6 integer, parameter :: sp = selected_real_kind(6) ! Single precision
|
|
|
7 end module kinds
|
|
|
8
|
|
|
9 module replacements
|
|
|
10 use kinds
|
|
|
11 contains
|
|
|
12 subroutine cshift_sp_3_v1 (array, shift, dim, res)
|
|
|
13 integer, parameter :: wp = sp
|
|
|
14 real(kind=wp), dimension(:,:,:), intent(in) :: array
|
|
|
15 integer, intent(in) :: shift, dim
|
|
|
16 real(kind=wp), dimension(:,:,:), intent(out) :: res
|
|
|
17 integer :: i,j,k
|
|
|
18 integer :: sh, rsh
|
|
|
19 integer :: n
|
|
|
20 integer :: n2, n3
|
|
|
21 res = 0
|
|
|
22 n3 = size(array,3)
|
|
|
23 n2 = size(array,2)
|
|
|
24 n1 = size(array,1)
|
|
|
25 if (dim == 1) then
|
|
|
26 n = n1
|
|
|
27 sh = modulo(shift, n)
|
|
|
28 rsh = n - sh
|
|
|
29 do k=1, n3
|
|
|
30 do j=1, n2
|
|
|
31 do i=1, rsh
|
|
|
32 res(i,j,k) = array(i+sh,j,k)
|
|
|
33 end do
|
|
|
34 do i=rsh+1,n
|
|
|
35 res(i,j,k) = array(i-rsh,j,k)
|
|
|
36 end do
|
|
|
37 end do
|
|
|
38 end do
|
|
|
39 else if (dim == 2) then
|
|
|
40 n = n2
|
|
|
41 sh = modulo(shift,n)
|
|
|
42 rsh = n - sh
|
|
|
43 do k=1, n3
|
|
|
44 do j=1, rsh
|
|
|
45 do i=1, n1
|
|
|
46 res(i,j,k) = array(i,j+sh, k)
|
|
|
47 end do
|
|
|
48 end do
|
|
|
49 do j=rsh+1, n
|
|
|
50 do i=1, n1
|
|
|
51 res(i,j,k) = array(i,j-rsh, k)
|
|
|
52 end do
|
|
|
53 end do
|
|
|
54 end do
|
|
|
55 else if (dim == 3) then
|
|
|
56 n = n3
|
|
|
57 sh = modulo(shift, n)
|
|
|
58 rsh = n - sh
|
|
|
59 do k=1, rsh
|
|
|
60 do j=1, n2
|
|
|
61 do i=1, n1
|
|
|
62 res(i,j,k) = array(i, j, k+sh)
|
|
|
63 end do
|
|
|
64 end do
|
|
|
65 end do
|
|
|
66 do k=rsh+1, n
|
|
|
67 do j=1, n2
|
|
|
68 do i=1, n1
|
|
|
69 res(i,j, k) = array(i, j, k-rsh)
|
|
|
70 end do
|
|
|
71 end do
|
|
|
72 end do
|
|
|
73 else
|
|
|
74 stop "Wrong argument to dim"
|
|
|
75 end if
|
|
|
76 end subroutine cshift_sp_3_v1
|
|
|
77 end module replacements
|
|
|
78
|
|
|
79 program testme
|
|
|
80 use kinds
|
|
|
81 use replacements
|
|
|
82 implicit none
|
|
|
83 integer, parameter :: wp = sp ! Working precision
|
|
|
84 INTEGER, PARAMETER :: n = 7
|
|
|
85 real(kind=wp), dimension(:,:,:), allocatable :: a,b,c
|
|
|
86 integer i, j, k
|
|
|
87 real:: t1, t2
|
|
|
88 integer, parameter :: nrep = 20
|
|
|
89
|
|
|
90 allocate (a(n,n,n), b(n,n,n),c(n,n,n))
|
|
|
91 call random_number(a)
|
|
|
92 do k = 1,3
|
|
|
93 do i=-3,3,2
|
|
|
94 call cshift_sp_3_v1 (a, i, k, b)
|
|
|
95 c = cshift(a,i,k)
|
|
131
|
96 if (any (c /= b)) STOP 1
|
|
111
|
97 end do
|
|
|
98 end do
|
|
|
99 deallocate (b,c)
|
|
|
100 allocate (b(n-1,n-1,n-1),c(n-1,n-1,n-1))
|
|
|
101 do k=1,3
|
|
|
102 do i=-3,3,2
|
|
|
103 call cshift_sp_3_v1 (a(1:n-1,1:n-1,1:n-1), i, k, b)
|
|
|
104 c = cshift(a(1:n-1,1:n-1,1:n-1), i, k)
|
|
131
|
105 if (any (c /= b)) STOP 2
|
|
111
|
106 end do
|
|
|
107 end do
|
|
|
108 end program testme
|
