46 PROGRAM test_xmap_all2all_fail
48 USE ftest_common,
ONLY: init_mpi, finish_mpi, test_abort
49 USE test_idxlist_utils,
ONLY: test_err_count
55 xt_set_abort_handler, xt_restore_default_abort_hndl
58 SUBROUTINE xfail_abort(comm, msg, source, line)
59 INTEGER,
INTENT(in) :: comm, line
60 CHARACTER(len=*),
INTENT(in) :: msg, source
61 END SUBROUTINE xfail_abort
63 INTEGER,
PARAMETER :: xi = xt_int_kind
64 CHARACTER(len=*),
PARAMETER :: filename =
'test_xmap_all2all_fail_f.f90'
65 INTEGER :: my_rank, ierror, list_size
68 CALL mpi_comm_rank(mpi_comm_world, my_rank, ierror)
70 CALL test_xmap1(list_size)
72 IF (test_err_count() /= 0) &
73 CALL test_abort(
"non-zero error count!", filename, __line__)
77 SUBROUTINE shift_idx(idx, offset)
78 INTEGER(xt_int_kind),
INTENT(inout) :: idx(:)
79 INTEGER(xt_int_kind),
INTENT(in) :: offset
82 idx(i) = idx(i) + int(my_rank, xi) * offset
84 END SUBROUTINE shift_idx
86 SUBROUTINE test_xmap(src_index_list, dst_index_list)
87 INTEGER(xt_int_kind),
INTENT(in) :: src_index_list(:), dst_index_list(:)
88 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
94 CALL xt_set_abort_handler(xfail_abort)
96 CALL xt_restore_default_abort_hndl
101 CALL test_abort(
"error in xmap construction", filename, __line__)
104 CALL test_abort(
"error in xt_xmap_get_num_sources", filename, __line__)
106 IF (rank(1) /= my_rank) &
107 CALL test_abort(
"error in xt_xmap_get_destination_ranks", &
111 IF (rank(1) /= my_rank) &
112 CALL test_abort(
"error in xt_xmap_get_source_ranks", &
115 END SUBROUTINE test_xmap
117 SUBROUTINE test_xmap1(num_idx)
118 INTEGER,
INTENT(in) :: num_idx
120 INTEGER(xt_int_kind) :: src_index_list(num_idx), &
121 dst_index_list(num_idx)
123 src_index_list(i) = int(i, xi)
125 CALL shift_idx(src_index_list, int(num_idx, xi))
127 dst_index_list(i) = int(num_idx - i + 2, xi)
129 CALL shift_idx(dst_index_list, int(num_idx, xi))
131 CALL test_xmap(src_index_list, dst_index_list)
132 END SUBROUTINE test_xmap1
134 SUBROUTINE parse_options
135 INTEGER :: i, num_cmd_args, arg_len
136 INTEGER,
PARAMETER :: max_opt_arg_len = 80
137 CHARACTER(max_opt_arg_len) :: optarg
138 num_cmd_args = command_argument_count()
140 DO WHILE (i < num_cmd_args)
141 CALL get_command_argument(i, optarg, arg_len)
142 IF (optarg(1:2) ==
'-s' .AND. i < num_cmd_args .AND. arg_len == 2)
THEN
143 CALL get_command_argument(i + 1, optarg, arg_len)
144 IF (arg_len > max_opt_arg_len) &
145 CALL test_abort(
'incorrect argument to command-line option -s', &
147 IF (optarg(1:arg_len) ==
"big")
THEN
149 ELSE IF (optarg(1:arg_len) ==
"small")
THEN
152 WRITE (0, *)
'arg to -s: ', optarg(1:arg_len)
153 CALL test_abort(
'incorrect argument to command-line option -s', &
158 WRITE (0, *)
'unexpected command-line argument parsing error: ', &
161 CALL test_abort(
'unexpected command-line argument', &
165 END SUBROUTINE parse_options
167 END PROGRAM test_xmap_all2all_fail
169 SUBROUTINE xfail_abort(comm, msg, source, line)
170 USE iso_c_binding,
ONLY: c_int
172 USE ftest_common,
ONLY: posix_exit
173 INTEGER,
INTENT(in) :: comm, line
174 CHARACTER(len=*),
INTENT(in) :: msg, source
176 WRITE (0,
'(4a,i0)') msg,
' at ', source,
', line ', line
177 #ifdef XT_NEED_MPI_ABORT_WORK_AROUND
178 WRITE (0,
'(a)')
'MPI_Abort(0xdeadbeef, 3)'
181 CALL mpi_abort(comm, 3, ierror)
182 CALL posix_exit(3_c_int)
183 END SUBROUTINE xfail_abort
void xt_initialize(MPI_Comm default_comm)
void xt_idxlist_delete(Xt_idxlist idxlist)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
void xt_xmap_delete(Xt_xmap xmap)
int xt_xmap_get_num_destinations(Xt_xmap xmap)
int xt_xmap_get_num_sources(Xt_xmap xmap)
void xt_xmap_get_source_ranks(Xt_xmap xmap, int *ranks)
void xt_xmap_get_destination_ranks(Xt_xmap xmap, int *ranks)
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)