1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
! { dg-do run }
program rnk_p
implicit none
integer, parameter :: n = 10
integer, parameter :: m = 5
integer, parameter :: s = 4
integer, parameter :: l = 4
integer, parameter :: u = s+l-1
integer :: a(n)
integer :: b(n,n)
integer :: c(n,n,n)
integer :: r(s*s*s)
integer :: i
a = reshape([(i, i=1,n)], [n])
b = reshape([(i, i=1,n*n)], [n,n])
c = reshape([(i, i=1,n*n*n)], [n,n,n])
r(1:s) = a(l:u)
call rnk_s(a(l:u), r(1:s))
r(1:s*s) = reshape(b(l:u,l:u), [s*s])
call rnk_s(b(l:u,l:u), r(1:s*s))
r = reshape(c(l:u,l:u,l:u), [s*s*s])
call rnk_s(c(l:u,l:7,l:u), r)
stop
contains
subroutine rnk_s(a, b)
integer, intent(in) :: a(..)
integer, intent(in) :: b(:)
!integer :: l(rank(a)), u(rank(a)) does not work due to Bug 94048
integer, allocatable :: lb(:), ub(:)
integer :: i, j, k, l
lb = lbound(a)
ub = ubound(a)
select rank(a)
rank(1)
if(any(lb/=lbound(a))) stop 11
if(any(ub/=ubound(a))) stop 12
if(size(a)/=size(b)) stop 13
do i = 1, size(a)
if(a(i)/=b(i)) stop 14
end do
rank(2)
if(any(lb/=lbound(a))) stop 21
if(any(ub/=ubound(a))) stop 22
if(size(a)/=size(b)) stop 23
k = 0
do j = 1, size(a, dim=2)
do i = 1, size(a, dim=1)
k = k + 1
if(a(i,j)/=b(k)) stop 24
end do
end do
rank(3)
if(any(lb/=lbound(a))) stop 31
if(any(ub/=ubound(a))) stop 32
if(size(a)/=size(b)) stop 33
l = 0
do k = 1, size(a, dim=3)
do j = 1, size(a, dim=2)
do i = 1, size(a, dim=1)
l = l + 1
! print *, a(i,j,k), b(l)
if(a(i,j,k)/=b(l)) stop 34
end do
end do
end do
rank default
stop 171
end select
deallocate(lb, ub)
return
end subroutine rnk_s
end program rnk_p
|
