[PATCH 6/13] Coarray shared memory library
Jerry D <[email protected]>
| Newsgroups | gmane.comp.gcc.patches,gmane.comp.gcc.fortran |
|---|---|
| Message-ID | <[email protected]> |
Dear all, as requested, See attached patch 6 of 13 Best Regards, Jerry
pr88076_v4_6.diff
(text/x-patch, 47.9 KB)
commit 9f74ce7aa6b7caadbd760a5920b87ac4016a5b92 Author: Andre Vehreschild <[email protected]> Date: Wed Jun 18 09:26:22 2025 +0200 Fortran: Enable coarray tests for multi image use [PR88076] 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. diff --git a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 index 2ee8ff0253d..50b4bab1603 100644 --- a/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/alloc_comp_4.f90 @@ -11,11 +11,19 @@ program main 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 index 5e1c4967248..7eccd7b578c 100644 --- a/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 @@ -61,7 +61,7 @@ end do 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 @@ -328,7 +328,7 @@ end do 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 @@ -403,7 +403,7 @@ if (this_image() < storage_size(caf)-2) then 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 @@ -544,7 +544,7 @@ if (this_image() < storage_size(caf)-2) then 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 @@ -628,26 +628,27 @@ 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/caf.exp b/gcc/testsuite/gfortran.dg/coarray/caf.exp index c8ea08980e2..9cd99f8e0cb 100644 --- a/gcc/testsuite/gfortran.dg/coarray/caf.exp +++ b/gcc/testsuite/gfortran.dg/coarray/caf.exp @@ -70,6 +70,12 @@ proc dg-compile-aux-modules { args } { } } +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. @@ -103,6 +109,13 @@ foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 b/gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 new file mode 100644 index 00000000000..9b4c44f1ada --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/co_reduce_string.f90 @@ -0,0 +1,94 @@ +!{ 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 + diff --git a/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 b/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 index 27db0e8d8ce..ce7c6288a61 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/coarray_allocated.f90 @@ -19,7 +19,7 @@ program p ! 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[*]) @@ -28,16 +28,17 @@ program p 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 index f90b65cb389..8f7a83a9c99 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_1.f90 @@ -21,6 +21,7 @@ subroutine char_test() 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 @@ -37,6 +38,7 @@ subroutine char_test() 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 @@ -53,6 +55,7 @@ subroutine char_test() 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 @@ -69,6 +72,7 @@ subroutine char_test() 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 @@ -91,6 +95,7 @@ subroutine char_test() 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 @@ -113,6 +118,7 @@ subroutine char_test() 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 @@ -135,6 +141,7 @@ subroutine char_test() 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 @@ -157,6 +164,7 @@ subroutine char_test() 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 @@ -179,6 +187,7 @@ subroutine char_test() 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 @@ -199,6 +208,7 @@ subroutine char_test() 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 @@ -219,6 +229,7 @@ subroutine char_test() 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 @@ -239,6 +250,7 @@ subroutine char_test() 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 @@ -261,6 +273,7 @@ subroutine char_test() 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 @@ -277,6 +290,7 @@ subroutine char_test() 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 @@ -293,6 +307,7 @@ subroutine char_test() 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 @@ -309,6 +324,7 @@ subroutine char_test() 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 @@ -331,6 +347,7 @@ subroutine char_test() 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 @@ -353,6 +370,7 @@ subroutine char_test() 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 @@ -375,6 +393,7 @@ subroutine char_test() 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 @@ -397,6 +416,7 @@ subroutine char_test() 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 @@ -419,6 +439,7 @@ subroutine char_test() 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 @@ -439,6 +460,7 @@ subroutine char_test() 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 @@ -459,6 +481,7 @@ subroutine char_test() 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 @@ -479,6 +502,7 @@ subroutine char_test() 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 @@ -502,6 +526,7 @@ subroutine char_test() 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 @@ -518,6 +543,7 @@ subroutine char_test() 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 @@ -534,6 +560,7 @@ subroutine char_test() 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 @@ -550,6 +577,7 @@ subroutine char_test() 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 @@ -572,6 +600,7 @@ subroutine char_test() 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 @@ -594,6 +623,7 @@ subroutine char_test() 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 @@ -616,6 +646,7 @@ subroutine char_test() 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 @@ -638,6 +669,7 @@ subroutine char_test() 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 @@ -660,6 +692,7 @@ subroutine char_test() 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 @@ -680,6 +713,7 @@ subroutine char_test() 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 @@ -700,6 +734,7 @@ subroutine char_test() 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 @@ -720,6 +755,7 @@ subroutine char_test() 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 @@ -743,7 +779,8 @@ subroutine char_test() 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 @@ -760,6 +797,7 @@ subroutine char_test() 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 @@ -776,6 +814,7 @@ subroutine char_test() 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 @@ -792,6 +831,7 @@ subroutine char_test() 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 @@ -814,6 +854,7 @@ subroutine char_test() 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 @@ -836,6 +877,7 @@ subroutine char_test() 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 @@ -858,6 +900,7 @@ subroutine char_test() 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 @@ -880,6 +923,7 @@ subroutine char_test() 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 @@ -902,6 +946,7 @@ subroutine char_test() 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 @@ -922,6 +967,7 @@ subroutine char_test() 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 @@ -942,6 +988,7 @@ subroutine char_test() 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 @@ -962,6 +1009,7 @@ subroutine char_test() 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 @@ -984,6 +1032,7 @@ subroutine char_test() 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 @@ -1000,6 +1049,7 @@ subroutine char_test() 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 @@ -1016,6 +1066,7 @@ subroutine char_test() 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 @@ -1032,6 +1083,7 @@ subroutine char_test() 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 @@ -1054,6 +1106,7 @@ subroutine char_test() 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 @@ -1076,6 +1129,7 @@ subroutine char_test() 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 @@ -1098,6 +1152,7 @@ subroutine char_test() 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 @@ -1120,6 +1175,7 @@ subroutine char_test() 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 @@ -1142,6 +1198,7 @@ subroutine char_test() 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 @@ -1162,6 +1219,7 @@ subroutine char_test() 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 @@ -1182,6 +1240,7 @@ subroutine char_test() 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 @@ -1202,6 +1261,7 @@ subroutine char_test() 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 @@ -1225,6 +1285,7 @@ subroutine char_test() 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 @@ -1241,6 +1302,7 @@ subroutine char_test() 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 @@ -1257,6 +1319,7 @@ subroutine char_test() 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 @@ -1273,6 +1336,7 @@ subroutine char_test() 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 @@ -1295,6 +1359,7 @@ subroutine char_test() 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 @@ -1317,6 +1382,7 @@ subroutine char_test() 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 @@ -1339,6 +1405,7 @@ subroutine char_test() 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 @@ -1361,6 +1428,7 @@ subroutine char_test() 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 @@ -1383,6 +1451,7 @@ subroutine char_test() 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 @@ -1403,6 +1472,7 @@ subroutine char_test() 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 @@ -1423,6 +1493,7 @@ subroutine char_test() 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 @@ -1443,6 +1514,7 @@ subroutine char_test() 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 index 7fd20851e0a..145835d461b 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f08 @@ -15,8 +15,8 @@ program pr98903 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 index c35ec1093c1..8eb64669628 100644 --- a/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_5.f90 @@ -13,68 +13,72 @@ program coindexed_5 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 index 4b45daab649..c569390e7c6 100644 --- a/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/dummy_3.f90 @@ -15,6 +15,7 @@ program pr77871 p%i = 42 allocate (p2(5)[*]) p2(:)%i = (/(i, i=0, 4)/) + sync all call s(p, 1) call s2(p2, 1) contains diff --git a/gcc/testsuite/gfortran.dg/coarray/event_1.f90 b/gcc/testsuite/gfortran.dg/coarray/event_1.f90 index 81dc90b7197..a9fecf93984 100644 --- a/gcc/testsuite/gfortran.dg/coarray/event_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/event_1.f90 @@ -5,47 +5,54 @@ 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/event_3.f08 b/gcc/testsuite/gfortran.dg/coarray/event_3.f08 index 60d3193f776..cedf636b79b 100644 --- a/gcc/testsuite/gfortran.dg/coarray/event_3.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/event_3.f08 @@ -11,8 +11,8 @@ program global_event 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) diff --git a/gcc/testsuite/gfortran.dg/coarray/event_4.f08 b/gcc/testsuite/gfortran.dg/coarray/event_4.f08 index de901c01aa4..26a1f59df03 100644 --- a/gcc/testsuite/gfortran.dg/coarray/event_4.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/event_4.f08 @@ -8,5 +8,6 @@ program event_4 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 index ca5fe4020d5..78d92daf071 100644 --- a/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 @@ -1,17 +1,44 @@ ! { 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 index b7ec5a6a9c9..f725f81d4aa 100644 --- a/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 @@ -18,7 +18,7 @@ program test_image_status_1 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\\)" } diff --git a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 index fb49289cb78..8866f237481 100644 --- a/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 @@ -1,12 +1,38 @@ ! { 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 index 8e96154996d..3d445b9b5e8 100644 --- a/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/lock_2.f90 @@ -58,6 +58,8 @@ if (stat /= 0) STOP 9 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) diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 index c284a566760..4da1b9569fe 100644 --- a/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/poly_run_3.f90 @@ -12,28 +12,28 @@ allocate(a(1)[*]) 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 b/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 index b0d27bdfb8f..8dd7df5d436 100644 --- a/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 @@ -19,7 +19,7 @@ if (lcobound(a, dim=1) /= 1 .or. ucobound(a,dim=1) /= num_images()) & 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 @@ -30,6 +30,7 @@ n3 = 3 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 @@ -47,7 +48,8 @@ contains 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 @@ -56,12 +58,13 @@ contains 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 index 0bf4a81a7e2..dadd00ecda7 100644 --- a/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 +++ b/gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 @@ -1,17 +1,44 @@ ! { 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 index 8633c4aa527..4abe5a3b548 100644 --- a/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/sync_1.f90 @@ -26,7 +26,6 @@ n = 5 sync all (stat=n,errmsg=str) if (n /= 0) STOP 2 - ! ! Test SYNC MEMORY ! @@ -42,17 +41,21 @@ n = 5 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 @@ -61,4 +64,5 @@ n = 5 sync images (*,errmsg=str,stat=n) if (n /= 0) STOP 6 +sync all end diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 index fe1e4c548c8..ceb4b19d517 100644 --- a/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 +++ b/gcc/testsuite/gfortran.dg/coarray/sync_3.f90 @@ -9,8 +9,9 @@ ! 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 @@ -58,17 +59,32 @@ if (this_image() == 1) then 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 diff --git a/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 b/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 new file mode 100644 index 00000000000..a96884549a3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/sync_team.f90 @@ -0,0 +1,33 @@ +!{ 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