1! { dg-do run }
2!
3! PR fortran/50981
4! Test the handling of optional, polymorphic and non-polymorphic arguments
5! to elemental procedures. 
6!
7! Original testcase by Tobias Burnus <burnus@net-b.de>
8
9implicit none
10type t
11  integer :: a
12end type t
13
14type t2
15  integer, allocatable :: a
16  integer, allocatable :: a2(:)
17  integer, pointer :: p => null()
18  integer, pointer :: p2(:) => null()
19end type t2
20
21type(t), allocatable :: ta, taa(:)
22type(t), pointer :: tp, tpa(:)
23class(t), allocatable :: ca, caa(:)
24class(t), pointer :: cp, cpa(:)
25
26type(t2) :: x
27
28integer :: s, v(2)
29
30tp => null()
31tpa => null()
32cp => null()
33cpa => null()
34
35! =============== sub1 ==================
36! SCALAR COMPONENTS: Non alloc/assoc
37
38s = 3
39v = [9, 33]
40
41call sub1 (s, x%a, .false.)
42call sub1 (v, x%a, .false.)
43!print *, s, v
44if (s /= 3) call abort()
45if (any (v /= [9, 33])) call abort()
46
47call sub1 (s, x%p, .false.)
48call sub1 (v, x%p, .false.)
49!print *, s, v
50if (s /= 3) call abort()
51if (any (v /= [9, 33])) call abort()
52
53
54! SCALAR COMPONENTS: alloc/assoc
55
56allocate (x%a, x%p)
57x%a = 4
58x%p = 5
59call sub1 (s, x%a, .true.)
60call sub1 (v, x%a, .true.)
61!print *, s, v
62if (s /= 4*2) call abort()
63if (any (v /= [4*2, 4*2])) call abort()
64
65call sub1 (s, x%p, .true.)
66call sub1 (v, x%p, .true.)
67!print *, s, v
68if (s /= 5*2) call abort()
69if (any (v /= [5*2, 5*2])) call abort()
70
71
72! ARRAY COMPONENTS: Non alloc/assoc
73
74v = [9, 33]
75
76call sub1 (v, x%a2, .false.)
77!print *, v
78if (any (v /= [9, 33])) call abort()
79
80call sub1 (v, x%p2, .false.)
81!print *, v
82if (any (v /= [9, 33])) call abort()
83
84
85! ARRAY COMPONENTS: alloc/assoc
86
87allocate (x%a2(2), x%p2(2))
88x%a2(:) = [84, 82]
89x%p2    = [35, 58]
90
91call sub1 (v, x%a2, .true.)
92!print *, v
93if (any (v /= [84*2, 82*2])) call abort()
94
95call sub1 (v, x%p2, .true.)
96!print *, v
97if (any (v /= [35*2, 58*2])) call abort()
98
99
100! =============== sub_t ==================
101! SCALAR DT: Non alloc/assoc
102
103s = 3
104v = [9, 33]
105
106call sub_t (s, ta, .false.)
107call sub_t (v, ta, .false.)
108!print *, s, v
109if (s /= 3) call abort()
110if (any (v /= [9, 33])) call abort()
111
112call sub_t (s, tp, .false.)
113call sub_t (v, tp, .false.)
114!print *, s, v
115if (s /= 3) call abort()
116if (any (v /= [9, 33])) call abort()
117
118call sub_t (s, ca, .false.)
119call sub_t (v, ca, .false.)
120!print *, s, v
121if (s /= 3) call abort()
122if (any (v /= [9, 33])) call abort()
123
124call sub_t (s, cp, .false.)
125call sub_t (v, cp, .false.)
126!print *, s, v
127if (s /= 3) call abort()
128if (any (v /= [9, 33])) call abort()
129
130! SCALAR COMPONENTS: alloc/assoc
131
132allocate (ta, tp, ca, cp)
133ta%a = 4
134tp%a = 5
135ca%a = 6
136cp%a = 7
137
138call sub_t (s, ta, .true.)
139call sub_t (v, ta, .true.)
140!print *, s, v
141if (s /= 4*2) call abort()
142if (any (v /= [4*2, 4*2])) call abort()
143
144call sub_t (s, tp, .true.)
145call sub_t (v, tp, .true.)
146!print *, s, v
147if (s /= 5*2) call abort()
148if (any (v /= [5*2, 5*2])) call abort()
149
150call sub_t (s, ca, .true.)
151call sub_t (v, ca, .true.)
152!print *, s, v
153if (s /= 6*2) call abort()
154if (any (v /= [6*2, 6*2])) call abort()
155
156call sub_t (s, cp, .true.)
157call sub_t (v, cp, .true.)
158!print *, s, v
159if (s /= 7*2) call abort()
160if (any (v /= [7*2, 7*2])) call abort()
161
162! ARRAY COMPONENTS: Non alloc/assoc
163
164v = [9, 33]
165
166call sub_t (v, taa, .false.)
167!print *, v
168if (any (v /= [9, 33])) call abort()
169
170call sub_t (v, tpa, .false.)
171!print *, v
172if (any (v /= [9, 33])) call abort()
173
174call sub_t (v, caa, .false.)
175!print *, v
176if (any (v /= [9, 33])) call abort()
177
178call sub_t (v, cpa, .false.)
179!print *, v
180if (any (v /= [9, 33])) call abort()
181
182deallocate(ta, tp, ca, cp)
183
184
185! ARRAY COMPONENTS: alloc/assoc
186
187allocate (taa(2), tpa(2))
188taa(1:2)%a = [44, 444]
189tpa(1:2)%a = [55, 555]
190allocate (caa(2), source=[t(66), t(666)])
191allocate (cpa(2), source=[t(77), t(777)])
192
193select type (caa)
194type is (t)
195  if (any (caa(:)%a /= [66, 666])) call abort()
196end select
197
198select type (cpa)
199type is (t)
200  if (any (cpa(:)%a /= [77, 777])) call abort()
201end select
202
203call sub_t (v, taa, .true.)
204!print *, v
205if (any (v /= [44*2, 444*2])) call abort()
206
207call sub_t (v, tpa, .true.)
208!print *, v
209if (any (v /= [55*2, 555*2])) call abort()
210
211
212call sub_t (v, caa, .true.)
213!print *, v
214if (any (v /= [66*2, 666*2])) call abort()
215
216call sub_t (v, cpa, .true.)
217!print *, v
218if (any (v /= [77*2, 777*2])) call abort()
219
220deallocate (taa, tpa, caa, cpa)
221
222
223contains
224
225  elemental subroutine sub1 (x, y, alloc)
226    integer, intent(inout) :: x
227    integer, intent(in), optional :: y
228    logical, intent(in) :: alloc
229    if (alloc .neqv. present (y)) &
230      x = -99
231    if (present(y)) &
232      x = y*2
233  end subroutine sub1
234
235  elemental subroutine sub_t(x, y, alloc)
236    integer, intent(inout) :: x
237    type(t), intent(in), optional :: y
238    logical, intent(in) :: alloc
239    if (alloc .neqv. present (y)) &
240      x = -99
241    if (present(y)) &
242      x = y%a*2
243  end subroutine sub_t
244
245end
246
247