Change some of regression tests to run on single and multiple images.
Add some new tests.
PR fortran/88076
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/alloc_comp_4.f90: Make multi image
compatible.
* gfortran.dg/coarray/atomic_2.f90: Same.
* gfortran.dg/coarray/caf.exp: Also test caf_shmem and choose
eight images as a default.
* gfortran.dg/coarray/coarray_allocated.f90: Add multi image
support.
* gfortran.dg/coarray/coindexed_1.f90: Same.
* gfortran.dg/coarray/coindexed_3.f08: Same.
* gfortran.dg/coarray/coindexed_5.f90: Same.
* gfortran.dg/coarray/dummy_3.f90: Same.
* gfortran.dg/coarray/event_1.f90: Same.
* gfortran.dg/coarray/event_3.f08: Same.
* gfortran.dg/coarray/event_4.f08: Same.
* gfortran.dg/coarray/failed_images_2.f08: Same.
* gfortran.dg/coarray/image_status_1.f08: Same.
* gfortran.dg/coarray/image_status_2.f08: Same.
* gfortran.dg/coarray/lock_2.f90: Same.
* gfortran.dg/coarray/poly_run_3.f90: Same.
* gfortran.dg/coarray/scalar_alloc_1.f90: Same.
* gfortran.dg/coarray/stopped_images_2.f08: Same.
* gfortran.dg/coarray/sync_1.f90: Same.
* gfortran.dg/coarray/sync_3.f90: Same.
* gfortran.dg/coarray/co_reduce_string.f90: New test.
* gfortran.dg/coarray/sync_team.f90: New test.
end type
type(mytype), save :: object[*]
- integer :: me
+ integer :: me, other
me=this_image()
- allocate(object%indices(me))
- object%indices = 42
+ other = me + 1
+ if (other .GT. num_images()) other = 1
+ if (me == num_images()) then
+ allocate(object%indices(me/2))
+ else
+ allocate(object%indices(me))
+ end if
+ object%indices = 42 * me
- if ( any( object[me]%indices(:) /= 42 ) ) STOP 1
+ sync all
+ if ( any( object[other]%indices(:) /= 42 * other ) ) STOP 1
+ sync all
end program
sync all
call atomic_ref(var, caf[num_images()], stat=stat)
-if (stat /= 0 .or. var /= num_images() + this_image()) STOP 12
+if (stat /= 0 .or. var /= num_images() * 2) STOP 12
do i = 1, num_images()
call atomic_ref(var, caf[i], stat=stat)
if (stat /= 0 .or. var /= num_images() + i) STOP 13
sync all
call atomic_ref(var, caf[num_images()], stat=stat)
-if (stat /= 0 .or. var /= num_images() + this_image()) STOP 45
+if (stat /= 0 .or. var /= num_images() * 2) STOP 45
do i = 1, num_images()
call atomic_ref(var, caf[i], stat=stat)
if (stat /= 0 .or. var /= num_images() + i) STOP 46
do i = this_image(), min(num_images(), storage_size(caf)-2)
var = -99
call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat)
- if (stat /= 0 .or. var <= 0) STOP 53
+ if (stat /= 0) STOP 53
end do
end if
sync all
do i = this_image(), min(num_images(), storage_size(caf)-2)
var = -99
call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat)
- if (stat /= 0 .or. (var < 0 .and. var /= -1)) STOP 68
+ if (stat /= 0) STOP 68
end do
end if
sync all
if (this_image() == 1) then
call atomic_cas(caf_log[num_images()], compare=.false., new=.false., old=var2, stat=stat)
- if (stat /= 0 .or. var2 .neqv. .true.) STOP 82
+ if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 82
call atomic_ref(var2, caf_log[num_images()], stat=stat)
- if (stat /= 0 .or. var2 .neqv. .true.) STOP 83
+ if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 83
end if
sync all
-if (this_image() == num_images() .and. caf_log .neqv. .true.) STOP 84
+if (this_image() == num_images() .and. (caf_log .neqv. .true.)) STOP 84
call atomic_ref(var2, caf_log[num_images()], stat=stat)
-if (stat /= 0 .or. var2 .neqv. .true.) STOP 85
+if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 85
sync all
if (this_image() == 1) then
call atomic_cas(caf_log[num_images()], compare=.true., new=.false., old=var2, stat=stat)
- if (stat /= 0 .or. var2 .neqv. .true.) STOP 86
+ if (stat /= 0 .or. (var2 .neqv. .true.)) STOP 86
call atomic_ref(var2, caf_log[num_images()], stat=stat)
- if (stat /= 0 .or. var2 .neqv. .false.) STOP 87
+ if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 87
end if
sync all
-if (this_image() == num_images() .and. caf_log .neqv. .false.) STOP 88
+if (this_image() == num_images() .and. (caf_log .neqv. .false.)) STOP 88
call atomic_ref(var2, caf_log[num_images()], stat=stat)
-if (stat /= 0 .or. var2 .neqv. .false.) STOP 89
+if (stat /= 0 .or. (var2 .neqv. .false.)) STOP 89
+sync all
end
}
}
+if { [getenv GFORTRAN_NUM_IMAGES] == "" } {
+ # Some caf_shmem tests need at least 8 images. This is also to limit the
+ # number of images on big machines preventing overload w/o any benefit.
+ setenv GFORTRAN_NUM_IMAGES 8
+}
+
# Main loop.
foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] {
# If we're only testing specific files and this isn't one of them, skip it.
dg-test $test "-fcoarray=lib $flags -lcaf_single" {}
cleanup-modules ""
}
+
+ foreach flags $option_list {
+ verbose "Testing $nshort (libcaf_shmem), $flags" 1
+ set gfortran_aux_module_flags "-fcoarray=lib $flags -lcaf_shmem"
+ dg-test $test "-fcoarray=lib $flags -lcaf_shmem" {}
+ cleanup-modules ""
+ }
}
torture-finish
dg-finish
--- /dev/null
+!{ dg-do run }
+
+! Check that co_reduce for strings works.
+! This test is motivated by OpenCoarray's co_reduce_string test.
+
+program co_reduce_strings
+
+ implicit none
+
+ integer, parameter :: numstrings = 10, strlen = 8, base_len = 4
+ character(len=strlen), dimension(numstrings) :: fixarr
+ character(len=strlen), dimension(:), allocatable :: allocarr
+ character(len=:), allocatable :: defarr(:)
+ character(len=strlen) :: expect
+ integer :: i
+
+ ! Construct the strings by postfixing foo by a number.
+ associate (me => this_image(), np => num_images())
+ if (np > 999) error stop "Too many images; increase format string modifiers and sizes!"
+
+ allocate(allocarr(numstrings))
+ do i = 1, numstrings
+ write(fixarr(i), "('foo',I04)") i * me
+ write(allocarr(i), "('foo',I04)") i * me
+ end do
+ ! Collectively reduce the maximum string.
+ call co_reduce(fixarr, fixmax)
+ call check(fixarr, 1)
+
+ call co_reduce(allocarr, strmax)
+ call check(allocarr, 2)
+ end associate
+
+ ! Construct the strings by postfixing foo by a number.
+ associate (me => this_image(), np => num_images())
+ allocate(character(len=base_len + 4)::defarr(numstrings))
+ do i = 1, numstrings
+ write(defarr(i), "('foo',I04)") i * me
+ end do
+ call sub_red(defarr)
+ end associate
+ sync all
+
+contains
+
+ pure function fixmax(lhs, rhs) result(m)
+ character(len=strlen), intent(in) :: lhs, rhs
+ character(len=strlen) :: m
+
+ if (lhs > rhs) then
+ m = lhs
+ else
+ m = rhs
+ end if
+ end function
+
+ pure function strmax(lhs, rhs) result(maxstr)
+ character(len=strlen), intent(in) :: lhs, rhs
+ character(len=strlen) :: maxstr
+
+ if (lhs > rhs) then
+ maxstr = lhs
+ else
+ maxstr = rhs
+ end if
+ end function
+
+ subroutine sub_red(str)
+ character(len=:), allocatable :: str(:)
+
+ call co_reduce(str, strmax)
+ call check(str, 3)
+ end subroutine
+
+ subroutine check(curr, stop_code)
+ character(len=*), intent(in) :: curr(:)
+ character(len=strlen) :: expect
+ integer, intent(in) :: stop_code
+ integer :: i
+
+ associate(np => num_images())
+ do i = 1, numstrings
+ write (expect, "('foo',I04)") i * np
+ if (curr(i) /= expect) then
+ ! On error print what we got and what we expected.
+ print *, this_image(), ": Got: ", curr(i), ", expected: ", expect, ", for i=", i
+ stop stop_code
+ end if
+ end do
+ end associate
+ end subroutine
+
+end program co_reduce_strings
+
! For this reason, -fcoarray=single and -fcoarray=lib give the
! same result
if (allocated (a[1])) stop 3
- if (allocated (c%x[1,2,3])) stop 4
+ if (allocated (c%x[1,1,1])) stop 4
! Allocate collectively
allocate(a[*])
if (.not. allocated (a)) stop 5
if (.not. allocated (c%x)) stop 6
if (.not. allocated (a[1])) stop 7
- if (.not. allocated (c%x[1,2,3])) stop 8
+ if (.not. allocated (c%x[1,1,1])) stop 8
- ! Deallocate collectively
+ sync all
+ ! Dellocate collectively
deallocate(a)
deallocate(c%x)
if (allocated (a)) stop 9
if (allocated (c%x)) stop 10
if (allocated (a[1])) stop 11
- if (allocated (c%x[1,2,3])) stop 12
+ if (allocated (c%x[1,1,1])) stop 12
end
! Expected: always local access and never a call to _gfortran_caf_get
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 1_"abc"
str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a[1] = str1a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
ustr2a = 4_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a[1] = ustr1a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 1_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a[1] = str2a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
ustr1a = 4_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a[1] = ustr2a
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = str1b
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = ustr1b
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = str2b
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = ustr2b
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = str1a
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = ustr1a
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = str2a
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = ustr2a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 1_"abc"
str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a = str1a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
ustr2a = 4_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a = ustr1a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 1_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a = str2a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
ustr1a = 4_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a = ustr2a[1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b = str1b(:)[1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b = ustr1b(:)[1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b = str2b(:)[1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b = ustr2b(:)[1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b = str1a[1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b = ustr1a[1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b = str2a[1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b = ustr2a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 1_"abc"
str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a[1] = str1a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
ustr2a = 4_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a[1] = ustr1a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 1_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a[1] = str2a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
ustr1a = 4_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a[1] = ustr2a[mod(1, num_images())+1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = str1b(:)[mod(1, num_images())+1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = ustr1b(:)[mod(1, num_images())+1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = str2b(:)[mod(1, num_images())+1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = ustr2b(:)[mod(1, num_images())+1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = str1a[mod(1, num_images())+1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = ustr1a[mod(1, num_images())+1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = str2a[mod(1, num_images())+1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = ustr2a[mod(1, num_images())+1]
end if
str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz"
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
- str1a = 1_"XXXXXXX"
+ str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a[1] = ustr1a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 4_"abc"
ustr2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a[1] = str1a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a[1] = ustr2a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 4_"abcde"
ustr1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a[1] = str2a
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = ustr1b
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = str1b
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = ustr2b
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = str2b
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = ustr1a
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = str1a
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = ustr2a
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = str2a
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a = ustr1a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 1_"abc"
ustr2a = 4_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a = str1a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a = ustr2a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 1_"abcde"
ustr1a = 4_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a = str2a[1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b = ustr1b(:)[1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b = str1b(:)[1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b = ustr2b(:)[1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b = str2b(:)[1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b = ustr1a[1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b = str1a[1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b = ustr2a[1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b = str2a[1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr1a = 4_"abc"
str2a = 1_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
str2a[1] = ustr1a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str1a = 1_"abc"
ustr2a = 4_"XXXXXXX"
+ sync all
if (this_image() == num_images()) then
ustr2a[1] = str1a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
ustr2a = 4_"abcde"
str1a = 1_"XXX"
+ sync all
if (this_image() == num_images()) then
str1a[1] = ustr2a[mod(1, num_images())+1]
end if
ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz"
str2a = 1_"abcde"
ustr1a = 4_"XXX"
+ sync all
if (this_image() == num_images()) then
ustr1a[1] = str2a[mod(1, num_images())+1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = ustr1b(:)[mod(1, num_images())+1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = str1b(:)[mod(1, num_images())+1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = ustr2b(:)[mod(1, num_images())+1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = str2b(:)[mod(1, num_images())+1]
end if
str2b(1) = 1_"XXXXXXX"
str2b(2) = 1_"YYYYYYY"
str2b(3) = 1_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
str2b(:)[1] = ustr1a[mod(1, num_images())+1]
end if
ustr2b(1) = 4_"XXXXXXX"
ustr2b(2) = 4_"YYYYYYY"
ustr2b(3) = 4_"ZZZZZZZ"
+ sync all
if (this_image() == num_images()) then
ustr2b(:)[1] = str1a[mod(1, num_images())+1]
end if
str1b(1) = 1_"XXX"
str1b(2) = 1_"YYY"
str1b(3) = 1_"ZZZ"
+ sync all
if (this_image() == num_images()) then
str1b(:)[1] = ustr2a[mod(1, num_images())+1]
end if
ustr1b(1) = 4_"XXX"
ustr1b(2) = 4_"YYY"
ustr1b(3) = 4_"ZZZ"
+ sync all
if (this_image() == num_images()) then
ustr1b(:)[1] = str2a[mod(1, num_images())+1]
end if
a = 42
s = 42
- ! Checking against single image only. Therefore team statements are
- ! not viable nor are they (yet) supported by GFortran.
+ sync all
+
if (a[1, team_number=-1, stat=s] /= 42) stop 1
if (s /= 0) stop 2
parentteam = get_team()
caf = [23, 32]
- form team(t_num, team, new_index=1)
+ form team(t_num, team) !, new_index=num_images() - this_image() + 1)
form team(t_num, formed_team)
change team(team, cell[*] => caf(2))
- ! for get_from_remote
- ! Checking against caf_single is very limitted.
- if (cell[1, team_number=t_num] /= 32) stop 1
- if (cell[1, team_number=st_num] /= 32) stop 2
- if (cell[1, team=parentteam] /= 32) stop 3
+ associate(me => this_image())
+ ! for get_from_remote
+ ! Checking against caf_single is very limitted.
+ if (cell[me, team_number=t_num] /= 32) stop 1
+ if (cell[me, team_number=st_num] /= 32) stop 2
+ if (cell[me, team=parentteam] /= 32) stop 3
- ! Check that team_number is validated
- lhs = cell[1, team_number=5, stat=stat]
- if (stat /= 1) stop 4
+ ! Check that team_number is validated
+ lhs = cell[me, team_number=5, stat=stat]
+ if (stat /= 1) stop 4
- ! Check that only access to active teams is valid
- stat = 42
- lhs = cell[1, team=formed_team, stat=stat]
- if (stat /= 1) stop 5
+ ! Check that only access to active teams is valid
+ stat = 42
+ lhs = cell[me, team=formed_team, stat=stat]
+ if (stat /= 1) stop 5
- ! for send_to_remote
- ! Checking against caf_single is very limitted.
- cell[1, team_number=t_num] = 45
- if (cell /= 45) stop 11
- cell[1, team_number=st_num] = 46
- if (cell /= 46) stop 12
- cell[1, team=parentteam] = 47
- if (cell /= 47) stop 13
+ ! for send_to_remote
+ ! Checking against caf_single is very limitted.
+ cell[me, team_number=t_num] = 45
+ if (cell /= 45) stop 11
+ cell[me, team_number=st_num] = 46
+ if (cell /= 46) stop 12
+ cell[me, team=parentteam] = 47
+ if (cell /= 47) stop 13
- ! Check that team_number is validated
- stat = -1
- cell[1, team_number=5, stat=stat] = 0
- if (stat /= 1) stop 14
+ ! Check that team_number is validated
+ stat = -1
+ cell[me, team_number=5, stat=stat] = 0
+ if (stat /= 1) stop 14
- ! Check that only access to active teams is valid
- stat = 42
- cell[1, team=formed_team, stat=stat] = -1
- if (stat /= 1) stop 15
+ ! Check that only access to active teams is valid
+ stat = 42
+ cell[me, team=formed_team, stat=stat] = -1
+ if (stat /= 1) stop 15
- ! for transfer_between_remotes
- ! Checking against caf_single is very limitted.
- cell[1, team_number=t_num] = caf(1)[1, team_number=-1]
- if (cell /= 23) stop 21
- cell[1, team_number=st_num] = caf(2)[1, team_number=-1]
- ! cell is an alias for caf(2) and has been overwritten by caf(1)!
- if (cell /= 23) stop 22
- cell[1, team=parentteam] = caf(1)[1, team= team]
- if (cell /= 23) stop 23
+ ! for transfer_between_remotes
+ ! Checking against caf_single is very limitted.
+ cell[me, team_number=t_num] = caf(1)[me, team_number=-1]
+ if (cell /= 23) stop 21
+ cell[me, team_number=st_num] = caf(2)[me, team_number=-1]
+ ! cell is an alias for caf(2) and has been overwritten by caf(1)!
+ if (cell /= 23) stop 22
+ cell[me, team=parentteam] = caf(1)[me, team= team]
+ if (cell /= 23) stop 23
- ! Check that team_number is validated
- stat = -1
- cell[1, team_number=5, stat=stat] = caf(1)[1, team_number= -1]
- if (stat /= 1) stop 24
- stat = -1
- cell[1, team_number=t_num] = caf(1)[1, team_number= -2, stat=stat]
- if (stat /= 1) stop 25
+ ! Check that team_number is validated
+ stat = -1
+ cell[me, team_number=5, stat=stat] = caf(1)[me, team_number= -1]
+ if (stat /= 1) stop 24
+ stat = -1
+ cell[me, team_number=t_num] = caf(1)[me, team_number= -2, stat=stat]
+ if (stat /= 1) stop 25
- ! Check that only access to active teams is valid
- stat = 42
- cell[1, team=formed_team, stat=stat] = caf(1)[1]
- if (stat /= 1) stop 26
- stat = 42
- cell[1] = caf(1)[1, team=formed_team, stat=stat]
- if (stat /= 1) stop 27
+ ! Check that only access to active teams is valid
+ stat = 42
+ cell[me, team=formed_team, stat=stat] = caf(1)[me]
+ if (stat /= 1) stop 26
+ stat = 42
+ cell[me] = caf(1)[me, team=formed_team, stat=stat]
+ if (stat /= 1) stop 27
+
+ sync all
+ end associate
end team
end program coindexed_5
p%i = 42
allocate (p2(5)[*])
p2(:)%i = (/(i, i=0, 4)/)
+ sync all
call s(p, 1)
call s2(p2, 1)
contains
use iso_fortran_env, only: event_type
implicit none
-type(event_type), save :: var[*]
+type(event_type), save, allocatable, dimension(:) :: events[:]
integer :: count, stat
-count = -42
-call event_query (var, count)
-if (count /= 0) STOP 1
-
-stat = 99
-event post (var, stat=stat)
-if (stat /= 0) STOP 2
-call event_query(var, count, stat=stat)
-if (count /= 1 .or. stat /= 0) STOP 3
-
-stat = 99
-event post (var[this_image()])
-call event_query(var, count)
-if (count /= 2) STOP 4
-
-stat = 99
-event wait (var)
-call event_query(var, count)
-if (count /= 1) STOP 5
-
-stat = 99
-event post (var)
-call event_query(var, count)
-if (count /= 2) STOP 6
-
-stat = 99
-event post (var)
-call event_query(var, count)
-if (count /= 3) STOP 7
-
-stat = 99
-event wait (var, until_count=2)
-call event_query(var, count)
-if (count /= 1) STOP 8
-
-stat = 99
-event wait (var, stat=stat, until_count=1)
-if (stat /= 0) STOP 9
-call event_query(event=var, stat=stat, count=count)
-if (count /= 0 .or. stat /= 0) STOP 10
+associate (me => this_image(), np => num_images())
+ allocate(events(np)[*])
+
+ associate(var => events(me))
+ count = -42
+ call event_query (var, count)
+ if (count /= 0) STOP 1
+
+ stat = 99
+ event post (var, stat=stat)
+ if (stat /= 0) STOP 2
+ call event_query(var, count, stat=stat)
+ if (count /= 1 .or. stat /= 0) STOP 3
+
+ count = 99
+ event post (var[this_image()])
+ call event_query(var, count)
+ if (count /= 2) STOP 4
+
+ count = 99
+ event wait (var)
+ call event_query(var, count)
+ if (count /= 1) STOP 5
+
+ count = 99
+ event post (var)
+ call event_query(var, count)
+ if (count /= 2) STOP 6
+
+ count = 99
+ event post (var)
+ call event_query(var, count)
+ if (count /= 3) STOP 7
+
+ count = 99
+ event wait (var, until_count=2)
+ call event_query(var, count)
+ if (count /= 1) STOP 8
+
+ stat = 99
+ event wait (var, stat=stat, until_count=1)
+ if (stat /= 0) STOP 9
+ count = 99
+ call event_query(event=var, stat=stat, count=count)
+ if (count /= 0 .or. stat /= 0) STOP 10
+ end associate
+end associate
end
contains
subroutine exchange
integer :: cnt
- event post(x[1])
- event post(x[1])
+ event post(x[this_image()])
+ event post(x[this_image()])
call event_query(x, cnt)
if (cnt /= 2) error stop 1
event wait(x, until_count=2)
type(event_type) done[*]
nc(1) = 1
event post(done[1])
- event wait(done,until_count=nc(1))
+ if (this_image() == 1) event wait(done,until_count=nc(1))
+ sync all
end
! { dg-do run }
program test_failed_images_2
+ use iso_fortran_env
implicit none
+ type(team_type) :: t
integer, allocatable :: fi(:)
integer(kind=1), allocatable :: sfi(:)
+ integer, allocatable :: rem_images(:)
+ integer :: i, st
- fi = failed_images()
- if (size(fi) > 0) error stop "failed_images result shall be empty array"
- sfi = failed_images(KIND=1)
- if (size(sfi) > 0) error stop "failed_images result shall be empty array"
- sfi = failed_images(KIND=8)
- if (size(sfi) > 0) error stop "failed_images result shall be empty array"
+ associate(np => num_images())
+ form team (1, t)
+ fi = failed_images()
+ if (size(fi) > 0) stop 1
+ sfi = failed_images(KIND=1)
+ if (size(sfi) > 0) stop 2
+ sfi = failed_images(KIND=8)
+ if (size(sfi) > 0) stop 3
+
+ fi = failed_images(t)
+ if (size(fi) > 0) stop 4
+ if (num_images() > 1) then
+ sync all
+ if (this_image() == 2) fail image
+ rem_images = (/ 1, ( i, i = 3, np )/)
+ ! Can't synchronize well on a failed image. Try with a sleep.
+ do i = 0, 10
+ if (size(failed_images()) == 0) then
+ call sleep(1)
+ else
+ exit
+ end if
+ end do
+ if (i == 10 .AND. size(failed_images()) == 0) stop 5
+ sync images (rem_images, stat=st)
+ if (any(failed_images() /= [2])) stop 6
+ if (any(failed_images(t, 8) /= [2])) stop 7
+ end if
+ end associate
end program test_failed_images_2
isv = image_status(k2) ! Ok
isv = image_status(k4) ! Ok
isv = image_status(k8) ! Ok
- isv = image_status(1, team=1) ! { dg-error "shall be of type 'team_type'" }
+ isv = image_status(1, team=1) ! { dg-error "'team' argument of 'image_status' intrinsic at \\(1\\) shall be of type 'team_type'" }
isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
! { dg-do run }
program test_image_status_2
- use iso_fortran_env , only : STAT_STOPPED_IMAGE
+ use iso_fortran_env
implicit none
+ type(team_type) :: t
+ integer :: i, st
+ integer, allocatable :: rem_images(:)
+
+ form team (1, t)
+
if (image_status(1) /= 0) error stop "Image 1 should report OK."
- if (image_status(2) /= STAT_STOPPED_IMAGE) error stop "Image 2 should be stopped."
- if (image_status(3) /= STAT_STOPPED_IMAGE) error stop "Image 3 should be stopped."
+ if (image_status(num_images() + 1) /= STAT_STOPPED_IMAGE) error stop "Image should be stopped."
+
+ if (image_status(1, t) /= 0) error stop "Image 1 in team t should report OK."
+
+ if (num_images() > 1) then
+ associate (np => num_images())
+ sync all
+ if (this_image() == 2) fail image
+ rem_images = (/ 1, ( i, i = 3, np )/)
+ ! Can't synchronize well on failed image. Try with a sleep.
+ do i = 0, 10
+ if (image_status(2) /= STAT_FAILED_IMAGE) then
+ call sleep(1)
+ else
+ exit
+ end if
+ end do
+ sync images (rem_images, stat=st)
+ if (image_status(2) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed."
+ if (image_status(2, t) /= STAT_FAILED_IMAGE) error stop "Image 2 has NOT status failed."
+ end associate
+ end if
end program test_image_status_2
UNLOCK(lock3(4), stat=stat)
if (stat /= 0) STOP 10
+! Ensure all other (/=1) images have released the locks.
+sync all
if (this_image() == 1) then
acquired = .false.
LOCK (lock1[this_image()], acquired_lock=acquired)
if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
STOP 1
if (any (lcobound(a) /= 1)) STOP 2
-if (any (ucobound(a) /= this_image())) STOP 3
+if (any (ucobound(a) /= num_images())) STOP 3
deallocate(a)
allocate(b[*])
if (this_image() == 1 .and. any (this_image(b) /= lcobound(b))) &
STOP 4
if (any (lcobound(b) /= 1)) STOP 5
-if (any (ucobound(b) /= this_image())) STOP 6
+if (any (ucobound(b) /= num_images())) STOP 6
deallocate(b)
allocate(a(1)[-10:*])
if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) &
STOP 7
if (any (lcobound(a) /= -10)) STOP 8
-if (any (ucobound(a) /= -11+this_image())) STOP 9
+if (any (ucobound(a) /= -11 + num_images())) STOP 9
deallocate(a)
allocate(d[23:*])
if (this_image() == 1 .and. any (this_image(d) /= lcobound(d))) &
STOP 10
if (any (lcobound(d) /= 23)) STOP 11
-if (any (ucobound(d) /= 22+this_image())) STOP 12
+if (any (ucobound(d) /= 22 + num_images())) STOP 12
deallocate(d)
end
deallocate(a)
allocate(a[4:*])
-a[this_image ()] = 8 - 2*this_image ()
+a[this_image () + 3] = 8 - 2*this_image ()
if (lcobound(a, dim=1) /= 4 .or. ucobound(a,dim=1) /= 3 + num_images()) &
STOP 4
allocate (B[n1:n2, n3:*])
if (any (lcobound(b) /= [-1, 3]) .or. lcobound(B, dim=2) /= n3) &
STOP 5
+sync all
call sub(A, B)
if (allocated (a)) STOP 6
STOP 8
if (lcobound(x, dim=1) /= 4 .or. ucobound(x,dim=1) /= 3 + num_images()) &
STOP 9
- if (x[this_image ()] /= 8 - 2*this_image ()) STOP 3
+ if (x[this_image () + 3] /= 8 - 2*this_image ()) STOP 10
+ sync all
deallocate(x)
end subroutine sub
integer, allocatable, SAVE :: a[:]
if (init) then
- if (allocated(a)) STOP 10
+ if (allocated(a)) STOP 11
allocate(a[*])
a = 45
else
- if (.not. allocated(a)) STOP 11
- if (a /= 45) STOP 12
+ if (.not. allocated(a)) STOP 12
+ if (a /= 45) STOP 13
+ sync all
deallocate(a)
end if
end subroutine two
! { dg-do run }
program test_stopped_images_2
+ use iso_fortran_env
implicit none
+ type(team_type) :: t
integer, allocatable :: si(:)
integer(kind=1), allocatable :: ssi(:)
+ integer, allocatable :: rem_images(:)
+ integer :: i, st
- si = stopped_images()
- if (size(si) > 0) error stop "stopped_images result shall be empty array"
- ssi = stopped_images(KIND=1)
- if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
- ssi = stopped_images(KIND=8)
- if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
+ associate(np => num_images())
+ form team (1, t)
+ si = stopped_images()
+ if (size(si) > 0) stop 1
+ ssi = stopped_images(KIND=1)
+ if (size(ssi) > 0) stop 2
+ ssi = stopped_images(KIND=8)
+ if (size(ssi) > 0) stop 3
+
+ si = stopped_images(t)
+ if (size(si) > 0) stop 4
+ if (num_images() > 1) then
+ sync all
+ if (this_image() == 2) stop
+ rem_images = (/ 1, ( i, i = 3, np )/)
+ ! Can't synchronize well on a stopped image. Try with a sleep.
+ do i = 0, 10
+ if (size(stopped_images()) == 0) then
+ call sleep(1)
+ else
+ exit
+ end if
+ end do
+ if (i == 10 .AND. size(stopped_images()) == 0) stop 5
+ sync images (rem_images, stat=st)
+ if (any(stopped_images() /= [2])) stop 6
+ if (any(stopped_images(t, 8) /= [2])) stop 7
+ end if
+ end associate
end program test_stopped_images_2
sync all (stat=n,errmsg=str)
if (n /= 0) STOP 2
-
!
! Test SYNC MEMORY
!
sync memory (errmsg=str,stat=n)
if (n /= 0) STOP 4
-
!
! Test SYNC IMAGES
!
sync images (*)
+
if (this_image() == 1) then
sync images (1)
sync images (1, errmsg=str)
sync images ([1])
end if
+! Need to sync all here, because otherwise sync image 1 may overlap with the
+! sync images(*, stat=n) below and that may hang for num_images() > 1.
+sync all
+
n = 5
sync images (*, stat=n)
if (n /= 0) STOP 5
sync images (*,errmsg=str,stat=n)
if (n /= 0) STOP 6
+sync all
end
! PR fortran/18918
implicit none
-integer :: n
-character(len=30) :: str
+integer :: n, st
+integer,allocatable :: others(:)
+character(len=40) :: str
critical
end critical
myCr: critical
sync images ([1])
end if
+! Need to sync all here, because otherwise sync image 1 may overlap with the
+! sync images(*, stat=n) below and that may hang for num_images() > 1.
+sync all
+
n = 5
sync images (*, stat=n)
if (n /= 0) STOP 5
n = 5
-sync images (*,errmsg=str,stat=n)
+sync images (*, errmsg=str, stat=n)
if (n /= 0) STOP 6
+if (this_image() == num_images()) then
+ others = (/( n, n=1, (num_images() - 1)) /)
+ sync images(others)
+else
+ sync images ( num_images() )
+end if
+
n = -1
-sync images ( num_images() )
-sync images (n) ! Invalid: "-1"
+st = 0
+sync images (n, errmsg=str, stat=st)
+if (st /= 1 .OR. str /= "Invalid image number -1 in SYNC IMAGES") STOP 7
+
+! Do this only on image 1, or output of error messages will clutter
+if (this_image() == 1) sync images (n) ! Invalid: "-1"
end
--- /dev/null
+!{ dg-do run }
+
+program main
+ use, intrinsic :: iso_fortran_env, only: team_type
+ implicit none
+ integer, parameter :: PARENT_TEAM = 1, CURRENT_TEAM = 2, CHILD_TEAM = 3
+ type(team_type) :: team(3)
+
+ if (num_images() > 7) then
+
+ form team (1, team(PARENT_TEAM))
+ change team (team(PARENT_TEAM))
+ form team (mod(this_image(),2) + 1, team(CURRENT_TEAM))
+ change team (team(CURRENT_TEAM))
+ form team(mod(this_image(),2) + 1, team(CHILD_TEAM))
+ sync team(team(PARENT_TEAM))
+ ! change order / number of syncs between teams to try to expose deadlocks
+ if (team_number() == 1) then
+ sync team(team(CURRENT_TEAM))
+ sync team(team(CHILD_TEAM))
+ else
+ sync team(team(CHILD_TEAM))
+ sync team(team(CURRENT_TEAM))
+ sync team(team(CHILD_TEAM))
+ sync team(team(CURRENT_TEAM))
+ end if
+ end team
+ end team
+
+ sync all
+ end if
+
+end program
projects / thirdparty / gcc.git / commitdiff
