1! RUN: %S/test_errors.sh %s %t %f18
2! C1141
3! A reference to the procedure IEEE_SET_HALTING_MODE ! from the intrinsic
4! module IEEE_EXCEPTIONS, shall not ! appear within a DO CONCURRENT construct.
5!
6! C1137
7! An image control statement shall not appear within a DO CONCURRENT construct.
8!
9! C1136
10! A RETURN statement shall not appear within a DO CONCURRENT construct.
11!
12! (11.1.7.5), paragraph 4
13! In a DO CONCURRENT, can't have an i/o statement with an ADVANCE= specifier
14
15subroutine do_concurrent_test1(i,n)
16  implicit none
17  integer :: i, n
18  do 10 concurrent (i = 1:n)
19!ERROR: An image control statement is not allowed in DO CONCURRENT
20     SYNC ALL
21!ERROR: An image control statement is not allowed in DO CONCURRENT
22     SYNC IMAGES (*)
23!ERROR: An image control statement is not allowed in DO CONCURRENT
24     SYNC MEMORY
25!ERROR: RETURN is not allowed in DO CONCURRENT
26     return
2710 continue
28end subroutine do_concurrent_test1
29
30subroutine do_concurrent_test2(i,j,n,flag)
31  use ieee_exceptions
32  use iso_fortran_env, only: team_type
33  implicit none
34  integer :: i, n
35  type(ieee_flag_type) :: flag
36  logical :: flagValue, halting
37  type(team_type) :: j
38  type(ieee_status_type) :: status
39  do concurrent (i = 1:n)
40!ERROR: An image control statement is not allowed in DO CONCURRENT
41    sync team (j)
42!ERROR: An image control statement is not allowed in DO CONCURRENT
43    change team (j)
44!ERROR: An image control statement is not allowed in DO CONCURRENT
45      critical
46!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
47        call ieee_get_status(status)
48!ERROR: IEEE_SET_HALTING_MODE is not allowed in DO CONCURRENT
49        call ieee_set_halting_mode(flag, halting)
50      end critical
51    end team
52!ERROR: ADVANCE specifier is not allowed in DO CONCURRENT
53    write(*,'(a35)',advance='no')
54  end do
55
56! The following is OK
57  do concurrent (i = 1:n)
58        call ieee_set_flag(flag, flagValue)
59  end do
60end subroutine do_concurrent_test2
61
62subroutine s1()
63  use iso_fortran_env
64  type(event_type) :: x
65  do concurrent (i = 1:n)
66!ERROR: An image control statement is not allowed in DO CONCURRENT
67    event post (x)
68  end do
69end subroutine s1
70
71subroutine s2()
72  use iso_fortran_env
73  type(event_type) :: x
74  do concurrent (i = 1:n)
75!ERROR: An image control statement is not allowed in DO CONCURRENT
76    event wait (x)
77  end do
78end subroutine s2
79
80subroutine s3()
81  use iso_fortran_env
82  type(team_type) :: t
83
84  do concurrent (i = 1:n)
85!ERROR: An image control statement is not allowed in DO CONCURRENT
86    form team(1, t)
87  end do
88end subroutine s3
89
90subroutine s4()
91  use iso_fortran_env
92  type(lock_type) :: l
93
94  do concurrent (i = 1:n)
95!ERROR: An image control statement is not allowed in DO CONCURRENT
96    lock(l)
97!ERROR: An image control statement is not allowed in DO CONCURRENT
98    unlock(l)
99  end do
100end subroutine s4
101
102subroutine s5()
103  do concurrent (i = 1:n)
104!ERROR: An image control statement is not allowed in DO CONCURRENT
105    stop
106  end do
107end subroutine s5
108
109subroutine s6()
110  type :: type0
111    integer, allocatable, dimension(:) :: type0_field
112    integer, allocatable, dimension(:), codimension[:] :: coarray_type0_field
113  end type
114
115  type :: type1
116    type(type0) :: type1_field
117  end type
118
119  type(type1) :: pvar;
120  type(type1) :: qvar;
121  integer, allocatable, dimension(:) :: array1
122  integer, allocatable, dimension(:) :: array2
123  integer, allocatable, codimension[:] :: ca, cb
124  integer, allocatable :: aa, ab
125
126  ! All of the following are allowable outside a DO CONCURRENT
127  allocate(array1(3), pvar%type1_field%type0_field(3), array2(9))
128  allocate(pvar%type1_field%coarray_type0_field(3)[*])
129  allocate(ca[*])
130  allocate(ca[*], pvar%type1_field%coarray_type0_field(3)[*])
131
132  do concurrent (i = 1:10)
133    allocate(pvar%type1_field%type0_field(3))
134  end do
135
136  do concurrent (i = 1:10)
137!ERROR: An image control statement is not allowed in DO CONCURRENT
138    allocate(ca[*])
139  end do
140
141  do concurrent (i = 1:10)
142!ERROR: An image control statement is not allowed in DO CONCURRENT
143    deallocate(ca)
144  end do
145
146  do concurrent (i = 1:10)
147!ERROR: An image control statement is not allowed in DO CONCURRENT
148    allocate(pvar%type1_field%coarray_type0_field(3)[*])
149  end do
150
151  do concurrent (i = 1:10)
152!ERROR: An image control statement is not allowed in DO CONCURRENT
153    deallocate(pvar%type1_field%coarray_type0_field)
154  end do
155
156  do concurrent (i = 1:10)
157!ERROR: An image control statement is not allowed in DO CONCURRENT
158    allocate(ca[*], pvar%type1_field%coarray_type0_field(3)[*])
159  end do
160
161  do concurrent (i = 1:10)
162!ERROR: An image control statement is not allowed in DO CONCURRENT
163    deallocate(ca, pvar%type1_field%coarray_type0_field)
164  end do
165
166! Call to MOVE_ALLOC of a coarray outside a DO CONCURRENT.  This is OK.
167call move_alloc(ca, cb)
168
169! Note that the errors below relating to MOVE_ALLOC() bing impure are bogus.
170! They're the result of the fact that access to the move_alloc() instrinsic
171! is not yet possible.
172
173  allocate(aa)
174  do concurrent (i = 1:10)
175!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
176    call move_alloc(aa, ab)
177  end do
178
179! Call to MOVE_ALLOC with non-coarray arguments in a DO CONCURRENT.  This is OK.
180
181  do concurrent (i = 1:10)
182!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
183!ERROR: An image control statement is not allowed in DO CONCURRENT
184    call move_alloc(ca, cb)
185  end do
186
187  do concurrent (i = 1:10)
188!ERROR: Call to an impure procedure is not allowed in DO CONCURRENT
189!ERROR: An image control statement is not allowed in DO CONCURRENT
190    call move_alloc(pvar%type1_field%coarray_type0_field, qvar%type1_field%coarray_type0_field)
191  end do
192end subroutine s6
193
194subroutine s7()
195  interface
196    pure integer function pf()
197    end function pf
198  end interface
199
200  type :: procTypeNotPure
201    procedure(notPureFunc), pointer, nopass :: notPureProcComponent
202  end type procTypeNotPure
203
204  type :: procTypePure
205    procedure(pf), pointer, nopass :: pureProcComponent
206  end type procTypePure
207
208  type(procTypeNotPure) :: procVarNotPure
209  type(procTypePure) :: procVarPure
210  integer :: ivar
211
212  procVarPure%pureProcComponent => pureFunc
213
214  do concurrent (i = 1:10)
215    print *, "hello"
216  end do
217
218  do concurrent (i = 1:10)
219    ivar = pureFunc()
220  end do
221
222  ! This should not generate errors
223  do concurrent (i = 1:10)
224    ivar = procVarPure%pureProcComponent()
225  end do
226
227  ! This should generate an error
228  do concurrent (i = 1:10)
229!ERROR: Call to an impure procedure component is not allowed in DO CONCURRENT
230    ivar = procVarNotPure%notPureProcComponent()
231  end do
232
233  contains
234    integer function notPureFunc()
235      notPureFunc = 2
236    end function notPureFunc
237
238    pure integer function pureFunc()
239      pureFunc = 3
240    end function pureFunc
241
242end subroutine s7
243