Skip to content

Commit c01e926

Browse files
zbeekmanzbeekman
committed
Merge remote-tracking branch 'neo/nc-fix'
2 parents 8594a4b + d6e1fda commit c01e926

File tree

5 files changed

+72
-26
lines changed

5 files changed

+72
-26
lines changed

‎CMakeLists.txt‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -763,7 +763,6 @@ if(opencoarrays_aware_compiler)
763763
# Fixed GCC 7 regressions, should run on GCC 6 and 7
764764
add_caf_test(static_event_post_issue_293 3 static_event_post_issue_293)
765765

766-
add_caf_test(issue-493-coindex-slice 8 issue-493-coindex-slice) # Contributed by @neok-m4700 in #493
767766

768767
# These co_reduce (#172, fixed by PR #332, addl discussion in PR
769768
# #331) tests are for bugs not regressions. Should be fixed in all
@@ -773,9 +772,11 @@ if(opencoarrays_aware_compiler)
773772
add_caf_test(co_reduce-factorial-int64 4 co_reduce-factorial-int64)
774773

775774
# issues reported by @neok-m4700
775+
add_caf_test(issue-493-coindex-slice 8 issue-493-coindex-slice)
776776
add_caf_test(issue-488-multi-dim-cobounds-true 8 issue-488-multi-dim-cobounds true)
777777
add_caf_test(issue-488-multi-dim-cobounds-false 8 issue-488-multi-dim-cobounds false)
778778
add_caf_test(issue-503-multidim-array-broadcast 2 issue-503-multidim-array-broadcast)
779+
add_caf_test(issue-503-non-contig-red-ndarray 2 issue-503-non-contig-red-ndarray)
779780
if((gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7.0.0)) OR (CAF_RUN_DEVELOPER_TESTS OR $ENV{OPENCOARRAYS_DEVELOPER}))
780781
add_caf_test(issue-515-mimic-mpi-gatherv 2 issue-515-mimic-mpi-gatherv)
781782
endif()

‎src/mpi/mpi_caf.c‎

Lines changed: 15 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -6791,7 +6791,7 @@ internal_co_reduce (MPI_Op op, gfc_descriptor_t *source, int result_image, int *
67916791
MPI_Datatype datatype = get_MPI_datatype (source, src_len);
67926792

67936793
size = 1;
6794-
for (j = 0; j < rank; j++)
6794+
for (j = 0; j < rank; ++j)
67956795
{
67966796
ptrdiff_t dimextent = source->dim[j]._ubound
67976797
- source->dim[j].lower_bound + 1;
@@ -6816,21 +6816,18 @@ internal_co_reduce (MPI_Op op, gfc_descriptor_t *source, int result_image, int *
68166816
goto co_reduce_cleanup;
68176817
}
68186818

6819-
for (i = 0; i < size; i++)
6819+
for (i = 0; i < size; ++i)
68206820
{
68216821
ptrdiff_t array_offset_sr = 0;
6822-
ptrdiff_t stride = 1;
6822+
ptrdiff_t tot_ext = 1;
68236823
ptrdiff_t extent = 1;
6824-
for (j = 0; j < GFC_DESCRIPTOR_RANK (source)-1; j++)
6824+
for (j = 0; j < rank-1; ++j)
68256825
{
6826-
array_offset_sr += ((i / (extent*stride))
6827-
% (source->dim[j]._ubound
6828-
- source->dim[j].lower_bound + 1))
6829-
* source->dim[j]._stride;
68306826
extent = (source->dim[j]._ubound - source->dim[j].lower_bound + 1);
6831-
stride = source->dim[j]._stride;
6827+
array_offset_sr += ((i / tot_ext) % extent) * source->dim[j]._stride;
6828+
tot_ext *= extent;
68326829
}
6833-
array_offset_sr += (i / extent) * source->dim[rank-1]._stride;
6830+
array_offset_sr += (i / tot_ext) * source->dim[rank-1]._stride;
68346831
void *sr = (void *)((char *) source->base_addr
68356832
+ array_offset_sr*GFC_DESCRIPTOR_SIZE (source));
68366833
if (result_image == 0)
@@ -6884,10 +6881,9 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e
68846881
MPI_Datatype datatype = get_MPI_datatype (a, 0);
68856882

68866883
size = 1;
6887-
for (j = 0; j < rank; j++)
6884+
for (j = 0; j < rank; ++j)
68886885
{
6889-
ptrdiff_t dimextent = a->dim[j]._ubound
6890-
- a->dim[j].lower_bound + 1;
6886+
ptrdiff_t dimextent = a->dim[j]._ubound - a->dim[j].lower_bound + 1;
68916887
if (dimextent < 0)
68926888
dimextent = 0;
68936889
size *= dimextent;
@@ -6919,21 +6915,18 @@ PREFIX (co_broadcast) (gfc_descriptor_t *a, int source_image, int *stat, char *e
69196915
caf_runtime_error ("Co_broadcast of character arrays not yet supported\n");
69206916
}
69216917

6922-
for (i = 0; i < size; i++)
6918+
for (i = 0; i < size; ++i)
69236919
{
69246920
ptrdiff_t array_offset_sr = 0;
6925-
ptrdiff_t stride = 1;
6921+
ptrdiff_t tot_ext = 1;
69266922
ptrdiff_t extent = 1;
6927-
for (j = 0; j < GFC_DESCRIPTOR_RANK (a)-1; j++)
6923+
for (j = 0; j < rank-1; ++j)
69286924
{
6929-
array_offset_sr += ((i / (extent*stride))
6930-
% (a->dim[j]._ubound
6931-
- a->dim[j].lower_bound + 1))
6932-
* a->dim[j]._stride;
69336925
extent = (a->dim[j]._ubound - a->dim[j].lower_bound + 1);
6934-
stride = a->dim[j]._stride;
6926+
array_offset_sr += ((i / tot_ext) % extent) * a->dim[j]._stride;
6927+
tot_ext *= extent;
69356928
}
6936-
array_offset_sr += (i / (extent * stride)) * a->dim[rank-1]._stride;
6929+
array_offset_sr += (i / tot_ext) * a->dim[rank-1]._stride;
69376930
void *sr = (void *)((char *) a->base_addr
69386931
+ array_offset_sr*GFC_DESCRIPTOR_SIZE (a));
69396932

‎src/tests/regression/open/issue-422-sendget.f90‎

Lines changed: 0 additions & 1 deletion
This file was deleted.

‎src/tests/regression/reported/CMakeLists.txt‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,11 +3,11 @@ caf_compile_executable(co_reduce-factorial-int8 issue-172-wrong-co_reduce-int8.f
33
caf_compile_executable(co_reduce-factorial-int64 issue-172-wrong-co_reduce-int64.f90)
44
caf_compile_executable(source-alloc-sync issue-243-source-allocation-no-sync.f90)
55
caf_compile_executable(convert-before-put issue-292-convert-type-before-put.f90)
6-
caf_compile_executable(issue-493-coindex-slice issue-493-coindex-slice.f90)
76
caf_compile_executable(issue-422-send issue-422-send.F90)
87
caf_compile_executable(issue-422-send-get issue-422-send-get.F90)
98
caf_compile_executable(issue-488-multi-dim-cobounds issue-488-multi-dim-cobounds.f90)
9+
caf_compile_executable(issue-493-coindex-slice issue-493-coindex-slice.f90)
1010
caf_compile_executable(issue-503-multidim-array-broadcast issue-503-multidim-array-broadcast.f90)
11+
caf_compile_executable(issue-503-non-contig-red-ndarray issue-503-non-contig-red-ndarray.f90)
1112
if (gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7.0.0))
1213
caf_compile_executable(issue-515-mimic-mpi-gatherv issue-515-mimic-mpi-gatherv.f90)
13-
endif()

‎src/tests/regression/reported/issue-503-non-contig-red-ndarray.f90‎

Lines changed: 53 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,53 @@
1+
program main
2+
real, allocatable, dimension(:, :, :, :) :: arr, arr_copy
3+
integer :: i, me, nimg
4+
real :: redc, sumc, sumnc, rednc
5+
real :: eps = epsilon(0.)
6+
logical :: failc, failnc
7+
8+
allocate(arr(9, 20, 3, 18))
9+
10+
me = this_image()
11+
nimg = num_images()
12+
13+
if (me == 1) then
14+
arr = reshape([(i, i=1, size(arr))], shape(arr))
15+
end if
16+
17+
call co_broadcast(arr, source_image=1)
18+
arr_copy = arr
19+
20+
print *, '==> CONTIGUOUS <=='
21+
sumc = sum(arr)
22+
redc = sumc
23+
call co_sum(redc)
24+
print *, 'sumc=', sumc
25+
print *, 'excpected: nimg * sumc=', nimg * sumc
26+
print *, 'got: redc=', redc
27+
28+
failc = abs(redc - nimg * sumc) > eps
29+
30+
print *, '==> NON CONTIGUOUS <=='
31+
sumnc = sum(arr(::3, ::2, :, ::5))
32+
33+
call co_sum(arr_copy)
34+
call co_sum(arr(::3, ::2, :, ::5))
35+
36+
rednc = sum(arr(::3, ::2, :, ::5))
37+
print *, 'sumnc=', sumnc
38+
print *, 'expected (nimg * sumnc)=', nimg * sumnc
39+
print *, 'expected=', sum(arr_copy(::3, ::2, :, ::5))
40+
print *, 'got: rednc=', rednc
41+
42+
failnc = abs(rednc - nimg * sumnc) > eps
43+
44+
sync all
45+
46+
if (failc .or. failnc) then
47+
write(*, *) 'Test failed!'
48+
error stop 5
49+
else
50+
write(*, *) 'Test passed.'
51+
end if
52+
deallocate(arr)
53+
end program

0 commit comments

Comments
 (0)