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
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
|
! RUN: %S/test_errors.sh %s %t %f18
! C1141
! A reference to the procedure IEEE_SET_HALTING_MODE ! from the intrinsic
! module IEEE_EXCEPTIONS, shall not ! appear within a DO CONCURRENT construct.
!
! C1137
! An image control statement shall not appear within a DO CONCURRENT construct.
!
! C1136
! A RETURN statement shall not appear within a DO CONCURRENT construct.
!
! (11.1.7.5), paragraph 4
! In a DO CONCURRENT, can't have an i/o statement with an ADVANCE= specifier
subroutine do_concurrent_test1(i,n)
implicit none
integer :: i, n
do 10 concurrent (i = 1:n)
!ERROR: An image control statement is not allowed in DO CONCURRENT
SYNC ALL
!ERROR: An image control statement is not allowed in DO CONCURRENT
SYNC IMAGES (*)
!ERROR: An image control statement is not allowed in DO CONCURRENT
SYNC MEMORY
!ERROR: RETURN is not allowed in DO CONCURRENT
return
10 continue
end subroutine do_concurrent_test1
subroutine do_concurrent_test2(i,j,n,flag)
use ieee_exceptions
use iso_fortran_env, only: team_type
implicit none
integer :: i, n
type(ieee_flag_type) :: flag
logical :: flagValue, halting
type(team_type) :: j
type(ieee_status_type) :: status
do concurrent (i = 1:n)
!ERROR: An image control statement is not allowed in DO CONCURRENT
sync team (j)
!ERROR: An image control statement is not allowed in DO CONCURRENT
change team (j)
!ERROR: An image control statement is not allowed in DO CONCURRENT
critical
!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
call ieee_get_status(status)
!ERROR: IEEE_SET_HALTING_MODE is not allowed in DO CONCURRENT
call ieee_set_halting_mode(flag, halting)
end critical
end team
!ERROR: ADVANCE specifier is not allowed in DO CONCURRENT
write(*,'(a35)',advance='no')
end do
! The following is OK
do concurrent (i = 1:n)
call ieee_set_flag(flag, flagValue)
end do
end subroutine do_concurrent_test2
subroutine s1()
use iso_fortran_env
type(event_type) :: x
do concurrent (i = 1:n)
!ERROR: An image control statement is not allowed in DO CONCURRENT
event post (x)
end do
end subroutine s1
subroutine s2()
use iso_fortran_env
type(event_type) :: x
do concurrent (i = 1:n)
!ERROR: An image control statement is not allowed in DO CONCURRENT
event wait (x)
end do
end subroutine s2
subroutine s3()
use iso_fortran_env
type(team_type) :: t
do concurrent (i = 1:n)
!ERROR: An image control statement is not allowed in DO CONCURRENT
form team(1, t)
end do
end subroutine s3
subroutine s4()
use iso_fortran_env
type(lock_type) :: l
do concurrent (i = 1:n)
!ERROR: An image control statement is not allowed in DO CONCURRENT
lock(l)
!ERROR: An image control statement is not allowed in DO CONCURRENT
unlock(l)
end do
end subroutine s4
subroutine s5()
do concurrent (i = 1:n)
!ERROR: An image control statement is not allowed in DO CONCURRENT
stop
end do
end subroutine s5
subroutine s6()
type :: type0
integer, allocatable, dimension(:) :: type0_field
integer, allocatable, dimension(:), codimension[:] :: coarray_type0_field
end type
type :: type1
type(type0) :: type1_field
end type
type(type1) :: pvar;
type(type1) :: qvar;
integer, allocatable, dimension(:) :: array1
integer, allocatable, dimension(:) :: array2
integer, allocatable, codimension[:] :: ca, cb
integer, allocatable :: aa, ab
! All of the following are allowable outside a DO CONCURRENT
allocate(array1(3), pvar%type1_field%type0_field(3), array2(9))
allocate(pvar%type1_field%coarray_type0_field(3)[*])
allocate(ca[*])
allocate(ca[*], pvar%type1_field%coarray_type0_field(3)[*])
do concurrent (i = 1:10)
allocate(pvar%type1_field%type0_field(3))
end do
do concurrent (i = 1:10)
!ERROR: An image control statement is not allowed in DO CONCURRENT
allocate(ca[*])
end do
do concurrent (i = 1:10)
!ERROR: An image control statement is not allowed in DO CONCURRENT
deallocate(ca)
end do
do concurrent (i = 1:10)
!ERROR: An image control statement is not allowed in DO CONCURRENT
allocate(pvar%type1_field%coarray_type0_field(3)[*])
end do
do concurrent (i = 1:10)
!ERROR: An image control statement is not allowed in DO CONCURRENT
deallocate(pvar%type1_field%coarray_type0_field)
end do
do concurrent (i = 1:10)
!ERROR: An image control statement is not allowed in DO CONCURRENT
allocate(ca[*], pvar%type1_field%coarray_type0_field(3)[*])
end do
do concurrent (i = 1:10)
!ERROR: An image control statement is not allowed in DO CONCURRENT
deallocate(ca, pvar%type1_field%coarray_type0_field)
end do
! Call to MOVE_ALLOC of a coarray outside a DO CONCURRENT. This is OK.
call move_alloc(ca, cb)
! Note that the errors below relating to MOVE_ALLOC() bing impure are bogus.
! They're the result of the fact that access to the move_alloc() instrinsic
! is not yet possible.
allocate(aa)
do concurrent (i = 1:10)
!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
call move_alloc(aa, ab)
end do
! Call to MOVE_ALLOC with non-coarray arguments in a DO CONCURRENT. This is OK.
do concurrent (i = 1:10)
!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
!ERROR: An image control statement is not allowed in DO CONCURRENT
call move_alloc(ca, cb)
end do
do concurrent (i = 1:10)
!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
!ERROR: An image control statement is not allowed in DO CONCURRENT
call move_alloc(pvar%type1_field%coarray_type0_field, qvar%type1_field%coarray_type0_field)
end do
end subroutine s6
subroutine s7()
interface
pure integer function pf()
end function pf
end interface
type :: procTypeNotPure
procedure(notPureFunc), pointer, nopass :: notPureProcComponent
end type procTypeNotPure
type :: procTypePure
procedure(pf), pointer, nopass :: pureProcComponent
end type procTypePure
type(procTypeNotPure) :: procVarNotPure
type(procTypePure) :: procVarPure
integer :: ivar
procVarPure%pureProcComponent => pureFunc
do concurrent (i = 1:10)
print *, "hello"
end do
do concurrent (i = 1:10)
ivar = pureFunc()
end do
! This should not generate errors
do concurrent (i = 1:10)
ivar = procVarPure%pureProcComponent()
end do
! This should generate an error
do concurrent (i = 1:10)
!ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
ivar = procVarNotPure%notPureProcComponent()
end do
contains
integer function notPureFunc()
notPureFunc = 2
end function notPureFunc
pure integer function pureFunc()
pureFunc = 3
end function pureFunc
end subroutine s7
|
