1! { dg-do run }
2!
3! This program does a correctness check for
4! ... = ARRAY[idx] and ... = SCALAR[idx]
5!
6
7
8!
9! FIXME: two/three has to be modified, test has to be checked and
10! diagnostic has to be removed
11!
12
13program main
14  implicit none
15  integer, parameter :: n = 3
16  integer, parameter :: m = 4
17
18  ! Allocatable coarrays
19  call one(-5, 1)
20  call one(0, 0)
21  call one(1, -5)
22  call one(0, -11)
23
24  ! Static coarrays
25  call two()
26  call three()
27contains
28  subroutine one(lb1, lb2)
29    integer, value :: lb1, lb2
30
31    integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
32    integer, allocatable :: caf(:,:)[:]
33    integer, allocatable :: a(:,:), b(:,:), c(:,:)
34
35    allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
36         a(lb1:n+lb1-1, lb2:m+lb2-1), &
37         b(lb1:n+lb1-1, lb2:m+lb2-1), &
38         c(lb1:n+lb1-1, lb2:m+lb2-1))
39
40    b = reshape([(i*33, i = 1, size(b))], shape(b))
41
42    ! Whole array: ARRAY = ARRAY
43    caf = -42
44    a = -42
45    c = -42
46    if (this_image() == num_images()) then
47      caf(:,:) = b(:,:)
48    endif
49    sync all
50    a(:,:) = b(:,:)
51    c(:,:) = caf(:,:)[num_images()]
52    if (any (a /= c)) then
53      call abort()
54    end if
55    sync all
56
57    ! Scalar assignment
58    caf = -42
59    a = -42
60    c = -42
61    if (this_image() == num_images()) then
62      caf(:,:) = b(:,:)
63    endif
64    sync all
65    do j = lb2, m+lb2-1
66      do i = n+lb1-1, lb1, -2
67        a(i,j) = b(i,j)
68        c(i,j) = caf(i,j)[num_images()]
69      end do
70    end do
71    do j = lb2, m+lb2-1
72      do i = lb1, n+lb1-1, 2
73        a(i,j) = b(i,j)
74        c(i,j) = caf(i,j)[num_images()]
75      end do
76    end do
77    if (any (a /= c)) then
78      call abort()
79    end if
80    sync all
81
82    ! Array sections with different ranges and pos/neg strides
83    do i_sgn1 = -1, 1, 2
84      do i_sgn2 = -1, 1, 2
85        do i=lb1, n+lb1-1
86          do i_e=lb1, n+lb1-1
87            do i_s=1, n
88              do j=lb2, m+lb2-1
89                do j_e=lb2, m+lb2-1
90                  do j_s=1, m
91                    ! ARRAY = ARRAY
92                    caf = -42
93                    a = -42
94                    c = -42
95                    if (this_image() == num_images()) then
96                      caf(:,:) = b(:,:)
97                    endif
98                    sync all
99                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
100                         = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
101                    c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
102                         = caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
103                    if (any (c /= a)) then
104                      call abort()
105                    end if
106                    sync all
107                  end do
108                end do
109              end do
110            end do
111          end do
112        end do
113      end do
114    end do
115  end subroutine one
116
117  subroutine two()
118    integer, parameter :: lb1 = -5, lb2 = 1
119
120    integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
121    integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
122    integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
123    integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
124    integer, save :: c(lb1:n+lb1-1, lb2:m+lb2-1)
125
126    b = reshape([(i*33, i = 1, size(b))], shape(b))
127
128    ! Whole array: ARRAY = ARRAY
129    caf = -42
130    a = -42
131    c = -42
132    if (this_image() == num_images()) then
133      caf(:,:) = b(:,:)
134    endif
135    sync all
136    a(:,:) = b(:,:)
137    c(:,:) = caf(:,:)[num_images()]
138    if (any (a /= c)) then
139      call abort()
140    end if
141    sync all
142
143    ! Scalar assignment
144    caf = -42
145    a = -42
146    c = -42
147    if (this_image() == num_images()) then
148      caf(:,:) = b(:,:)
149    endif
150    sync all
151    do j = lb2, m+lb2-1
152      do i = n+lb1-1, lb1, -2
153        a(i,j) = b(i,j)
154        c(i,j) = caf(i,j)[num_images()]
155      end do
156    end do
157    do j = lb2, m+lb2-1
158      do i = lb1, n+lb1-1, 2
159        a(i,j) = b(i,j)
160        c(i,j) = caf(i,j)[num_images()]
161      end do
162    end do
163    if (any (a /= c)) then
164      call abort()
165    end if
166    sync all
167
168    ! Array sections with different ranges and pos/neg strides
169    do i_sgn1 = -1, 1, 2
170      do i_sgn2 = -1, 1, 2
171        do i=lb1, n+lb1-1
172          do i_e=lb1, n+lb1-1
173            do i_s=1, n
174              do j=lb2, m+lb2-1
175                do j_e=lb2, m+lb2-1
176                  do j_s=1, m
177                    ! ARRAY = ARRAY
178                    caf = -42
179                    a = -42
180                    c = -42
181                    if (this_image() == num_images()) then
182                      caf(:,:) = b(:,:)
183                    endif
184                    sync all
185                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
186                         = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
187                    c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
188                         = caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
189                    if (any (c /= a)) then
190                      call abort()
191                    end if
192                    sync all
193                  end do
194                end do
195              end do
196            end do
197          end do
198        end do
199      end do
200    end do
201  end subroutine two
202
203  subroutine three()
204    integer, parameter :: lb1 = 0, lb2 = 0
205
206    integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
207    integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
208    integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
209    integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
210    integer, save :: c(lb1:n+lb1-1, lb2:m+lb2-1)
211
212    b = reshape([(i*33, i = 1, size(b))], shape(b))
213
214    ! Whole array: ARRAY = ARRAY
215    caf = -42
216    a = -42
217    c = -42
218    if (this_image() == num_images()) then
219      caf(:,:) = b(:,:)
220    endif
221    sync all
222    a(:,:) = b(:,:)
223    c(:,:) = caf(:,:)[num_images()]
224    if (any (a /= c)) then
225      call abort()
226    end if
227    sync all
228
229    ! Scalar assignment
230    caf = -42
231    a = -42
232    c = -42
233    if (this_image() == num_images()) then
234      caf(:,:) = b(:,:)
235    endif
236    sync all
237    do j = lb2, m+lb2-1
238      do i = n+lb1-1, lb1, -2
239        a(i,j) = b(i,j)
240        c(i,j) = caf(i,j)[num_images()]
241      end do
242    end do
243    do j = lb2, m+lb2-1
244      do i = lb1, n+lb1-1, 2
245        a(i,j) = b(i,j)
246        c(i,j) = caf(i,j)[num_images()]
247      end do
248    end do
249    if (any (a /= c)) then
250      call abort()
251    end if
252    sync all
253
254    ! Array sections with different ranges and pos/neg strides
255    do i_sgn1 = -1, 1, 2
256      do i_sgn2 = -1, 1, 2
257        do i=lb1, n+lb1-1
258          do i_e=lb1, n+lb1-1
259            do i_s=1, n
260              do j=lb2, m+lb2-1
261                do j_e=lb2, m+lb2-1
262                  do j_s=1, m
263                    ! ARRAY = ARRAY
264                    caf = -42
265                    a = -42
266                    c = -42
267                    if (this_image() == num_images()) then
268                      caf(:,:) = b(:,:)
269                    endif
270                    sync all
271                    a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
272                         = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
273                    c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
274                         = caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()]
275                    if (any (c /= a)) then
276                      call abort()
277                    end if
278                    sync all
279                  end do
280                end do
281              end do
282            end do
283          end do
284        end do
285      end do
286    end do
287  end subroutine three
288end program main
289