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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
! { dg-do run }
!
! Contributed by Andre Vehreschild
! Check more elaborate class array addressing.
module m1
type InnerBaseT
integer, allocatable :: a(:)
end type InnerBaseT
type, extends(InnerBaseT) :: InnerT
integer :: i
end type InnerT
type BaseT
class(InnerT), allocatable :: arr(:,:)
contains
procedure P
end type BaseT
contains
subroutine indir(this, mat)
class(BaseT) :: this
class(InnerT), intent(inout) :: mat(:,:)
call this%P(mat)
end subroutine indir
subroutine P(this, mat)
class(BaseT) :: this
class(InnerT), intent(inout) :: mat(:,:)
integer :: i,j
mat%i = 42
do i= 1, ubound(mat, 1)
do j= 1, ubound(mat, 2)
if (.not. allocated(mat(i,j)%a)) then
allocate(mat(i,j)%a(10), source = 72)
end if
end do
end do
mat(1,1)%i = 9
mat(1,1)%a(5) = 1
end subroutine
end module m1
program test
use m1
class(BaseT), allocatable, target :: o
class(InnerT), pointer :: i_p(:,:)
class(InnerBaseT), allocatable :: i_a(:,:)
integer i,j,l
allocate(o)
allocate(o%arr(2,2))
allocate(InnerT::i_a(2,2))
o%arr%i = 1
i_p => o%arr
call o%P(i_p)
if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) STOP 1
do l= 1, 10
do i= 1, 2
do j= 1,2
if ((i == 1 .and. j == 1 .and. l == 5 .and. &
o%arr(i,j)%a(5) /= 1) &
.or. (.not. (i == 1 .and. j == 1 .and. l == 5) &
.and. o%arr(i,j)%a(l) /= 72)) STOP 2
end do
end do
end do
select type (i_a)
type is (InnerT)
call o%P(i_a)
do l= 1, 10
do i= 1, 2
do j= 1,2
if ((i == 1 .and. j == 1 .and. l == 5 .and. &
i_a(i,j)%a(5) /= 1) &
.or. (.not. (i == 1 .and. j == 1 .and. l == 5) &
.and. i_a(i,j)%a(l) /= 72)) STOP 3
end do
end do
end do
end select
i_p%i = 4
call indir(o, i_p)
if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) STOP 4
end program test
! vim:ts=2:sts=2:cindent:sw=2:tw=80:
|
