Skip to content

Commit 8318f9e

Browse files
author
neok-m4700
committed
FIX for issue 511
1 parent 15dc8c3 commit 8318f9e

File tree

4 files changed

+55
-24
lines changed

4 files changed

+55
-24
lines changed

‎CMakeLists.txt‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -882,6 +882,7 @@ if(opencoarrays_aware_compiler)
882882
add_caf_test(issue-503-multidim-array-broadcast 2 issue-503-multidim-array-broadcast)
883883
add_caf_test(issue-503-non-contig-red-ndarray 2 issue-503-non-contig-red-ndarray)
884884
add_caf_test(issue-552-send_by_ref-singleton 2 issue-552-send_by_ref-singleton)
885+
add_caf_test(issue-511-incorrect-shape 1 issue-511-incorrect-shape)
885886
if((gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7.0.0)) OR (CAF_RUN_DEVELOPER_TESTS OR $ENV{OPENCOARRAYS_DEVELOPER}))
886887
add_caf_test(issue-515-mimic-mpi-gatherv 2 issue-515-mimic-mpi-gatherv)
887888
endif()

‎src/mpi/mpi_caf.c‎

Lines changed: 30 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -4222,7 +4222,7 @@ get_for_ref(caf_reference_t *ref, size_t *i, size_t dst_index,
42224222
GFC_DESCRIPTOR_RANK(src), ref_rank);
42234223
for (int r = 0; r < GFC_DESCRIPTOR_RANK(src); ++r)
42244224
{
4225-
dprint("remote desc dim[%d] = (lb = %zd, ub = %zd, stride = %zd)\n",
4225+
dprint("remote desc dim[%d] = (lb=%zd, ub=%zd, stride=%zd)\n",
42264226
r, src->dim[r].lower_bound, src->dim[r]._ubound,
42274227
src->dim[r]._stride);
42284228
}
@@ -4676,15 +4676,14 @@ PREFIX(get_by_ref) (caf_token_t token, int image_index,
46764676
GFC_DESCRIPTOR_RANK(src), ref_rank);
46774677
for (i = 0; i < GFC_DESCRIPTOR_RANK(src); ++i)
46784678
{
4679-
dprint("remote desc dim[%zd] = (lb = %zd, ub = %zd, stride = %zd)\n",
4679+
dprint("remote desc dim[%zd] = (lb=%zd, ub=%zd, stride=%zd)\n",
46804680
i, src->dim[i].lower_bound, src->dim[i]._ubound,
46814681
src->dim[i]._stride);
46824682
}
46834683
#endif
46844684
for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
46854685
{
46864686
array_ref = riter->u.a.mode[i];
4687-
dprint("i = %zd, array_ref = %s\n", i, caf_array_ref_str[array_ref]);
46884687
switch (array_ref)
46894688
{
46904689
case CAF_ARR_REF_VECTOR:
@@ -4755,6 +4754,8 @@ case kind: \
47554754
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
47564755
return;
47574756
}
4757+
dprint("i = %zd, array_ref = %s, delta = %ld\n", i,
4758+
caf_array_ref_str[array_ref], delta);
47584759
if (delta <= 0)
47594760
return;
47604761
/* Check the various properties of the destination array.
@@ -4776,7 +4777,7 @@ case kind: \
47764777
return;
47774778
}
47784779
/* Do further checks, when the source is not scalar. */
4779-
else if (delta != 1)
4780+
else if (delta != 1 || realloc_required)
47804781
{
47814782
/* Check that the extent is not scalar and we are not in an array
47824783
* ref for the dst side. */
@@ -4820,7 +4821,7 @@ case kind: \
48204821
GFC_DESCRIPTOR_EXTENT(dst, dst_cur_dim) != delta;
48214822
/* When it already known, that a realloc is needed or the extent
48224823
* does not match the needed one. */
4823-
if (realloc_required || realloc_needed || extent_mismatch)
4824+
if (realloc_needed || extent_mismatch)
48244825
{
48254826
/* Check whether dst is reallocatable. */
48264827
if (unlikely(!dst_reallocatable))
@@ -4872,7 +4873,6 @@ case kind: \
48724873
for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
48734874
{
48744875
array_ref = riter->u.a.mode[i];
4875-
dprint("i = %zd, array_ref = %s\n", i, caf_array_ref_str[array_ref]);
48764876
switch (array_ref)
48774877
{
48784878
case CAF_ARR_REF_VECTOR:
@@ -4927,6 +4927,8 @@ case kind: \
49274927
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
49284928
return;
49294929
}
4930+
dprint("i = %zd, array_ref = %s, delta = %ld\n",
4931+
i, caf_array_ref_str[array_ref], delta);
49304932
if (delta <= 0)
49314933
return;
49324934
/* Check the various properties of the destination array.
@@ -4940,15 +4942,15 @@ case kind: \
49404942
/* When dst is an array. */
49414943
if (dst_rank > 0)
49424944
{
4943-
/* Check that dst_cur_dim is valid for dst. Can be superceeded
4945+
/* Check that dst_cur_dim is valid for dst. Can be superceeded
49444946
* only by scalar data. */
49454947
if (dst_cur_dim >= dst_rank && delta != 1)
49464948
{
49474949
caf_runtime_error(rankoutofrange, stat, NULL, 0);
49484950
return;
49494951
}
49504952
/* Do further checks, when the source is not scalar. */
4951-
else if (delta != 1)
4953+
else if (delta != 1 || realloc_required)
49524954
{
49534955
/* Check that the extent is not scalar and we are not in an array
49544956
* ref for the dst side. */
@@ -4975,7 +4977,7 @@ case kind: \
49754977
GFC_DESCRIPTOR_EXTENT(dst, dst_cur_dim) != delta;
49764978
/* When it is already known, that a realloc is needed or
49774979
* the extent does not match the needed one. */
4978-
if (realloc_required || realloc_needed || extent_mismatch)
4980+
if (realloc_needed || extent_mismatch)
49794981
{
49804982
/* Check whether dst is reallocatable. */
49814983
if (unlikely(!dst_reallocatable))
@@ -5061,8 +5063,8 @@ case kind: \
50615063
remote_memptr = mpi_token->memptr;
50625064
dst_index = 0;
50635065
#ifdef EXTRA_DEBUG_OUTPUT
5064-
dprint("dst_rank: %zd\n", GFC_DESCRIPTOR_RANK(dst));
5065-
for (i = 0; i < GFC_DESCRIPTOR_RANK(dst); ++i)
5066+
dprint("dst_rank: %zd\n", dst_rank);
5067+
for (i = 0; i < dst_rank; ++i)
50665068
{
50675069
dprint("dst_dim[%zd] = (%zd, %zd)\n",
50685070
i, dst->dim[i].lower_bound, dst->dim[i]._ubound);
@@ -5394,7 +5396,7 @@ send_for_ref(caf_reference_t *ref, size_t *i, size_t src_index,
53945396
GFC_DESCRIPTOR_RANK(src), ref_rank);
53955397
for (int r = 0; r < GFC_DESCRIPTOR_RANK(src); ++r)
53965398
{
5397-
dprint("remote desc dim[%d] = (lb = %zd, ub = %zd, stride = %zd)\n",
5399+
dprint("remote desc dim[%d] = (lb=%zd, ub=%zd, stride=%zd)\n",
53985400
r, src->dim[r].lower_bound, src->dim[r]._ubound,
53995401
src->dim[r]._stride);
54005402
}
@@ -5882,15 +5884,14 @@ PREFIX(send_by_ref) (caf_token_t token, int image_index,
58825884
GFC_DESCRIPTOR_RANK(dst), ref_rank);
58835885
for (i = 0; i < GFC_DESCRIPTOR_RANK(dst); ++i)
58845886
{
5885-
dprint("remote desc dim[%zd] = (lb = %zd, ub = %zd, stride = %zd)\n",
5887+
dprint("remote desc dim[%zd] = (lb=%zd, ub=%zd, stride=%zd)\n",
58865888
i, dst->dim[i].lower_bound, dst->dim[i]._ubound,
58875889
dst->dim[i]._stride);
58885890
}
58895891
#endif
58905892
for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
58915893
{
58925894
array_ref = riter->u.a.mode[i];
5893-
dprint("i = %zd, array_ref = %s\n", i, caf_array_ref_str[array_ref]);
58945895
switch (array_ref)
58955896
{
58965897
case CAF_ARR_REF_VECTOR:
@@ -5960,6 +5961,8 @@ case kind: \
59605961
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
59615962
return;
59625963
} // switch
5964+
dprint("i = %zd, array_ref = %s, delta = %ld\n",
5965+
i, caf_array_ref_str[array_ref], delta);
59635966
if (delta <= 0)
59645967
return;
59655968
if (dst != NULL)
@@ -5975,7 +5978,7 @@ case kind: \
59755978
/* When dst is an array. */
59765979
if (dst_rank > 0)
59775980
{
5978-
/* Check that src_cur_dim is valid for dst. Can be superceeded
5981+
/* Check that src_cur_dim is valid for dst. Can be superceeded
59795982
* only by scalar data. */
59805983
if (src_cur_dim >= dst_rank && delta != 1)
59815984
{
@@ -6025,7 +6028,6 @@ case kind: \
60256028
for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
60266029
{
60276030
array_ref = riter->u.a.mode[i];
6028-
dprint("i = %zd, array_ref = %s\n", i, caf_array_ref_str[array_ref]);
60296031
switch (array_ref)
60306032
{
60316033
case CAF_ARR_REF_VECTOR:
@@ -6079,6 +6081,8 @@ case kind: \
60796081
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
60806082
return;
60816083
} // switch
6084+
dprint("i = %zd, array_ref = %s, delta = %ld\n",
6085+
i, caf_array_ref_str[array_ref], delta);
60826086
if (delta <= 0)
60836087
return;
60846088
if (dst != NULL)
@@ -6094,8 +6098,8 @@ case kind: \
60946098
/* When dst is an array. */
60956099
if (dst_rank > 0)
60966100
{
6097-
/* Check that src_cur_dim is valid for dst. Can be
6098-
* superceeded only by scalar data. */
6101+
/* Check that src_cur_dim is valid for dst. Can be superceeded
6102+
* only by scalar data. */
60996103
if (src_cur_dim >= dst_rank && delta != 1)
61006104
{
61016105
caf_runtime_error(rankoutofrange, stat, NULL, 0);
@@ -6368,15 +6372,14 @@ PREFIX(sendget_by_ref) (caf_token_t dst_token, int dst_image_index,
63686372
GFC_DESCRIPTOR_RANK(src), ref_rank);
63696373
for (i = 0; i < GFC_DESCRIPTOR_RANK(src); ++i)
63706374
{
6371-
dprint("remote desc dim[%zd] = (lb = %zd, ub = %zd, stride = %zd)\n",
6375+
dprint("remote desc dim[%zd] = (lb=%zd, ub=%zd, stride=%zd)\n",
63726376
i, src->dim[i].lower_bound, src->dim[i]._ubound,
63736377
src->dim[i]._stride);
63746378
}
63756379
#endif
63766380
for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
63776381
{
63786382
array_ref = riter->u.a.mode[i];
6379-
dprint("i = %zd, array_ref = %s\n", i, caf_array_ref_str[array_ref]);
63806383
switch (array_ref)
63816384
{
63826385
case CAF_ARR_REF_VECTOR:
@@ -6446,6 +6449,8 @@ case kind: \
64466449
caf_runtime_error(unknownarrreftype, src_stat, NULL, 0);
64476450
return;
64486451
} // switch
6452+
dprint("i = %zd, array_ref = %s, delta = %ld\n",
6453+
i, caf_array_ref_str[array_ref], delta);
64496454
if (delta <= 0)
64506455
return;
64516456
size *= (ptrdiff_t)delta;
@@ -6460,7 +6465,6 @@ case kind: \
64606465
for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
64616466
{
64626467
array_ref = riter->u.a.mode[i];
6463-
dprint("i = %zd, array_ref = %s\n", i, caf_array_ref_str[array_ref]);
64646468
switch (array_ref)
64656469
{
64666470
case CAF_ARR_REF_VECTOR:
@@ -6513,6 +6517,8 @@ case kind: \
65136517
caf_runtime_error(unknownarrreftype, src_stat, NULL, 0);
65146518
return;
65156519
} // switch
6520+
dprint("i = %zd, array_ref = %s, delta = %ld\n",
6521+
i, caf_array_ref_str[array_ref], delta);
65166522
if (delta <= 0)
65176523
return;
65186524
size *= (ptrdiff_t)delta;
@@ -6665,7 +6671,8 @@ PREFIX(is_present) (caf_token_t token, int image_index, caf_reference_t *refs)
66656671
for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
66666672
{
66676673
array_ref = riter->u.a.mode[i];
6668-
dprint("i = %zd, array_ref = %s\n", i, caf_array_ref_str[array_ref]);
6674+
dprint("i = %zd, array_ref = %s\n",
6675+
i, caf_array_ref_str[array_ref]);
66696676
switch (array_ref)
66706677
{
66716678
case CAF_ARR_REF_FULL:
@@ -6805,8 +6812,7 @@ PREFIX(is_present) (caf_token_t token, int image_index, caf_reference_t *refs)
68056812
GFC_DESCRIPTOR_RANK(src), ref_rank);
68066813
for (i = 0; i < GFC_DESCRIPTOR_RANK(src); ++i)
68076814
{
6808-
dprint("remote desc dim[%zd] = "
6809-
"(lb = %zd, ub = %zd, stride = %zd)\n",
6815+
dprint("remote desc dim[%zd] = (lb=%zd, ub=%zd, stride=%zd)\n",
68106816
i, src_desc.dim[i].lower_bound, src_desc.dim[i]._ubound,
68116817
src_desc.dim[i]._stride);
68126818
}

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ caf_compile_executable(issue-503-multidim-array-broadcast issue-503-multidim-arr
1111
caf_compile_executable(issue-503-non-contig-red-ndarray issue-503-non-contig-red-ndarray.f90)
1212
caf_compile_executable(issue-322-non-coarray-vector-idx-lhs issue-322-non-coarray-vector-idx-lhs.f90)
1313
caf_compile_executable(issue-552-send_by_ref-singleton issue-552-send_by_ref-singleton.f90)
14+
caf_compile_executable(issue-511-incorrect-shape issue-511-incorrect-shape.f90)
1415
if (gfortran_compiler AND (NOT CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 7.0.0))
1516
caf_compile_executable(issue-515-mimic-mpi-gatherv issue-515-mimic-mpi-gatherv.f90)
1617
endif()

‎src/tests/regression/reported/issue-511-incorrect-shape.f90‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
program main
2+
implicit none
3+
4+
type foo
5+
logical, allocatable :: x(:, :)[:]
6+
end type
7+
8+
type(foo) :: bar
9+
integer :: shp_loc(2), shp_rem(2)
10+
11+
allocate(bar % x(2, 1)[*])
12+
13+
shp_loc = shape(bar % x) ! local shape
14+
shp_rem = shape(bar % x(:, :)[1]) ! remote shape on this image
15+
print *, shp_loc, shp_rem
16+
17+
if (any(shp_loc /= shp_rem)) then
18+
write(*, *) 'Test failed!'
19+
error stop 5
20+
else
21+
write(*, *) 'Test passed.'
22+
end if
23+
end program

0 commit comments

Comments
 (0)