1program source_allocation_no_sync
2  !! author: Damian Rouson and Izaak Beekman
3  !! category: regression
4  !!
5  !! [Issue #243](https://github.com/sourceryinstitute/opencoarrays/issues/243)
6  !!
7  !! [GFortran PR 78505](https://gcc.gnu.org/bugzilla/show_bug.cgi?id=78505):
8  !!
9  !! @note The test must be run with less than or equal to 32 images,
10  !! and the number of images must be a power of two. Valid numbers of
11  !! images are: 2, 4, 8, 16, or 32
12  !!
13  !! Sourced allocation of a coarray object performs a synchronization
14  !! after the allocation, BUT *before* the assignment of
15  !! `source`. This violates the
16  !! [standard](http://open-std.org/JTC1/SC22/WG5/5559) Section
17  !! 9.7.1.2, paragraph 4:
18  !!
19  !! > When an ALLOCATE statement is executed for which an
20  !! > allocate-object is a coarray, there is an implicit
21  !! > synchronization of all active images in the current team. On
22  !! > those images, if no error condition other than
23  !! > STAT_STOPPED_IMAGE or STAT_FAILED_IMAGE occurs, execution of
24  !! > the segment (11.6.2) following the statement is delayed until
25  !! > all other active images in the current team have executed the
26  !! > same statement the same number of times in this team. The
27  !! > coarray shall not become allocated on an image unless it is
28  !! > successfully allocated on all active images in this team.
29  !!
30
31  implicit none
32  integer, allocatable :: f(:)[:]
33  integer, parameter :: num_points=32
34  integer :: me,ni,my_num_points,neighbor_last_element
35  me = this_image()
36  if (mod(num_points,num_images())/=0) error stop "num_points not evenly divisible by num_images()"
37  my_num_points = num_points/num_images()
38  allocate( f(my_num_points)[*], source = 1 )
39  if (me>1) then
40     neighbor_last_element = f(my_num_points)[me-1]
41     if (neighbor_last_element /=1) then
42        print *,"Image ",me," gets ",neighbor_last_element
43        error stop "Synchronization did not happen after assignment in sourced allocation!"
44     end if
45  end if
46  sync all
47  if ( me == 1 ) then
48     write(*,'(a)') "Test passed."
49  end if
50end program source_allocation_no_sync
51