1! { dg-do run }
2! { dg-options "-fcoarray=single" }
3!
4! PR fortran/50981
5! PR fortran/54618
6!
7
8  implicit none
9  type t
10   integer, allocatable :: i
11  end type t
12  type, extends (t):: t2
13   integer, allocatable :: j
14  end type t2
15
16  class(t), allocatable :: xa, xa2(:), xac[:], xa2c(:)[:]
17  class(t), pointer :: xp, xp2(:)
18
19  xp => null()
20  xp2 => null()
21
22  call suba(alloc=.false., prsnt=.false.)
23  call suba(xa, alloc=.false., prsnt=.true.)
24  if (.not. allocated (xa)) STOP 1
25  if (.not. allocated (xa%i)) STOP 2
26  if (xa%i /= 5) STOP 3
27  xa%i = -3
28  call suba(xa, alloc=.true., prsnt=.true.)
29  if (allocated (xa)) STOP 4
30
31  call suba2(alloc=.false., prsnt=.false.)
32  call suba2(xa2, alloc=.false., prsnt=.true.)
33  if (.not. allocated (xa2)) STOP 5
34  if (size (xa2) /= 1) STOP 6
35  if (.not. allocated (xa2(1)%i)) STOP 7
36  if (xa2(1)%i /= 5) STOP 8
37  xa2(1)%i = -3
38  call suba2(xa2, alloc=.true., prsnt=.true.)
39  if (allocated (xa2)) STOP 9
40
41  call subp(alloc=.false., prsnt=.false.)
42  call subp(xp, alloc=.false., prsnt=.true.)
43  if (.not. associated (xp)) STOP 10
44  if (.not. allocated (xp%i)) STOP 11
45  if (xp%i /= 5) STOP 12
46  xp%i = -3
47  call subp(xp, alloc=.true., prsnt=.true.)
48  if (associated (xp)) STOP 13
49
50  call subp2(alloc=.false., prsnt=.false.)
51  call subp2(xp2, alloc=.false., prsnt=.true.)
52  if (.not. associated (xp2)) STOP 14
53  if (size (xp2) /= 1) STOP 15
54  if (.not. allocated (xp2(1)%i)) STOP 16
55  if (xp2(1)%i /= 5) STOP 17
56  xp2(1)%i = -3
57  call subp2(xp2, alloc=.true., prsnt=.true.)
58  if (associated (xp2)) STOP 18
59
60  call subac(alloc=.false., prsnt=.false.)
61  call subac(xac, alloc=.false., prsnt=.true.)
62  if (.not. allocated (xac)) STOP 19
63  if (.not. allocated (xac%i)) STOP 20
64  if (xac%i /= 5) STOP 21
65  xac%i = -3
66  call subac(xac, alloc=.true., prsnt=.true.)
67  if (allocated (xac)) STOP 22
68
69  call suba2c(alloc=.false., prsnt=.false.)
70  call suba2c(xa2c, alloc=.false., prsnt=.true.)
71  if (.not. allocated (xa2c)) STOP 23
72  if (size (xa2c) /= 1) STOP 24
73  if (.not. allocated (xa2c(1)%i)) STOP 25
74  if (xa2c(1)%i /= 5) STOP 26
75  xa2c(1)%i = -3
76  call suba2c(xa2c, alloc=.true., prsnt=.true.)
77  if (allocated (xa2c)) STOP 27
78
79contains
80 subroutine suba2c(x, prsnt, alloc)
81   class(t), optional, allocatable :: x(:)[:]
82   logical prsnt, alloc
83   if (present (x) .neqv. prsnt) STOP 28
84   if (prsnt) then
85     if (alloc .neqv. allocated(x)) STOP 29
86     if (.not. allocated (x)) then
87       allocate (x(1)[*])
88       x(1)%i = 5
89     else
90       if (x(1)%i /= -3) STOP 30
91       deallocate (x)
92     end if
93   end if
94 end subroutine suba2c
95
96 subroutine subac(x, prsnt, alloc)
97   class(t), optional, allocatable :: x[:]
98   logical prsnt, alloc
99   if (present (x) .neqv. prsnt) STOP 31
100   if (present (x)) then
101     if (alloc .neqv. allocated(x)) STOP 32
102     if (.not. allocated (x)) then
103       allocate (x[*])
104       x%i = 5
105     else
106       if (x%i /= -3) STOP 33
107       deallocate (x)
108     end if
109   end if
110 end subroutine subac
111
112 subroutine suba2(x, prsnt, alloc)
113   class(t), optional, allocatable :: x(:)
114   logical prsnt, alloc
115   if (present (x) .neqv. prsnt) STOP 34
116   if (prsnt) then
117     if (alloc .neqv. allocated(x)) STOP 35
118     if (.not. allocated (x)) then
119       allocate (x(1))
120       x(1)%i = 5
121     else
122       if (x(1)%i /= -3) STOP 36
123       deallocate (x)
124     end if
125   end if
126 end subroutine suba2
127
128 subroutine suba(x, prsnt, alloc)
129   class(t), optional, allocatable :: x
130   logical prsnt, alloc
131   if (present (x) .neqv. prsnt) STOP 37
132   if (present (x)) then
133     if (alloc .neqv. allocated(x)) STOP 38
134     if (.not. allocated (x)) then
135       allocate (x)
136       x%i = 5
137     else
138       if (x%i /= -3) STOP 39
139       deallocate (x)
140     end if
141   end if
142 end subroutine suba
143
144 subroutine subp2(x, prsnt, alloc)
145   class(t), optional, pointer :: x(:)
146   logical prsnt, alloc
147   if (present (x) .neqv. prsnt) STOP 40
148   if (present (x)) then
149     if (alloc .neqv. associated(x)) STOP 41
150     if (.not. associated (x)) then
151       allocate (x(1))
152       x(1)%i = 5
153     else
154       if (x(1)%i /= -3) STOP 42
155       deallocate (x)
156     end if
157   end if
158 end subroutine subp2
159
160 subroutine subp(x, prsnt, alloc)
161   class(t), optional, pointer :: x
162   logical prsnt, alloc
163   if (present (x) .neqv. prsnt) STOP 43
164   if (present (x)) then
165     if (alloc .neqv. associated(x)) STOP 44
166     if (.not. associated (x)) then
167       allocate (x)
168       x%i = 5
169     else
170       if (x%i /= -3) STOP 45
171       deallocate (x)
172     end if
173   end if
174 end subroutine subp
175end
176