|
| 1 | +program main |
| 2 | + !! OpenCoarrays issue #488 MWE |
| 3 | + !! =========================== |
| 4 | + !! |
| 5 | + !! https://github.com/sourceryinstitute/OpenCoarrays/issues/488 |
| 6 | + !! |
| 7 | + !! Running with 8 images, scattering from rank 1 fails when using a coarray |
| 8 | + !! in a derived type, whereas we observe no issue with pure coarrays. |
| 9 | + !! |
| 10 | + !! Should be run with 8 images as follows: |
| 11 | + !! cafrun -np 8 ./a.out false |
| 12 | + !! cafrun -np 8 ./a.out true |
| 13 | + implicit none |
| 14 | + |
| 15 | + type co_arr |
| 16 | + real, allocatable :: a(:, :)[:, :] |
| 17 | + end type |
| 18 | + |
| 19 | + type(co_arr) :: co1 ! derived type with coarray |
| 20 | + real, allocatable :: co2(:, :)[:, :] ! pure coarray |
| 21 | + real, allocatable :: glob(:, :), buf2d(:, :) |
| 22 | + integer, parameter :: nx = 2, ny = 3 ! local chunk, same over all images |
| 23 | + integer :: me, nimg, mx, my, i, j, k |
| 24 | + character(len = *), parameter :: tab = char(9), nl = char(10) |
| 25 | + character(len = 10) :: arg |
| 26 | + logical :: switch, test_passed |
| 27 | + |
| 28 | + test_passed = .false. |
| 29 | + call get_command_argument(1, arg) |
| 30 | + read (arg, '(L)') switch |
| 31 | + |
| 32 | + me = this_image() |
| 33 | + nimg = num_images() |
| 34 | + mx = nimg / 2 ! 2d grid distribution |
| 35 | + my = nimg / mx |
| 36 | + |
| 37 | + if (nimg /= 8) then |
| 38 | + stop 'example for 8 images' |
| 39 | + end if |
| 40 | + |
| 41 | + allocate(co1 % a(nx, ny)[mx, *]) |
| 42 | + allocate(co2(nx, ny)[mx, *]) |
| 43 | + allocate(buf2d(nx, ny), glob(mx * nx, my * ny)) |
| 44 | + |
| 45 | + if (me == 1) print *, 'global size', [(mx * nx), (my * ny)], nl, 'local size', [nx, ny] |
| 46 | + |
| 47 | + ! call random_number(glob) |
| 48 | + glob = reshape([(i, i = 1, (mx * nx) * (my * ny))], shape(glob)) |
| 49 | + |
| 50 | + sync all ! separate segments |
| 51 | + if (me == 1) then |
| 52 | + ! scatter glob from root (1st image) |
| 53 | + |
| 54 | + ! local to local |
| 55 | + co1 % a = glob(:nx, :ny) |
| 56 | + co2 = glob(:nx, :ny) |
| 57 | + |
| 58 | + ! loop over all other images |
| 59 | + do i = 1, mx |
| 60 | + do j = 1, my |
| 61 | + k = image_index(co2, [i, j]) |
| 62 | + if (k /= 1) then |
| 63 | + buf2d = glob((i - 1) * nx + 1:i * nx, (j - 1) * ny + 1:j * ny) ! send buffer |
| 64 | + ! print *, 'filling up image #', k, '[', [i, j], ']', nl, tab, '==>', buf2d, nl |
| 65 | + if (switch) then |
| 66 | + co1 % a(:nx, :ny)[i, j] = buf2d ! <= failure |
| 67 | + else |
| 68 | + co2(:nx, :ny)[i, j] = buf2d ! ok |
| 69 | + end if |
| 70 | + end if |
| 71 | + end do |
| 72 | + end do |
| 73 | + end if |
| 74 | + sync all |
| 75 | + |
| 76 | + ! output local arrays after scattering |
| 77 | + ! print *, me, 'co1', co1 % a, nl, me, 'co2', co2 |
| 78 | + |
| 79 | + ! collect results on rank 1 |
| 80 | + call co_sum(co1 % a, result_image = 1) |
| 81 | + call co_sum(co2, result_image = 1) |
| 82 | + |
| 83 | + sync all |
| 84 | + test_passed = abs(sum(glob) - sum(merge(co1 % a, co2, switch))) < epsilon(0.) |
| 85 | + if (me == 1) then |
| 86 | + print *, 'all close ?', test_passed |
| 87 | + if(test_passed) then |
| 88 | + write(*,*) 'Test passed.' |
| 89 | + else |
| 90 | + write(*,*) 'Test failed!' |
| 91 | + endif |
| 92 | + end if |
| 93 | + deallocate(co1 % a, co2, glob) |
| 94 | +end program |
0 commit comments