Yet Another eXchange Tool  0.9.0
test_xmap_all2all_fail_f.f90
1 
12 !
13 ! Keywords:
14 ! Maintainer: Jörg Behrens <behrens@dkrz.de>
15 ! Moritz Hanke <hanke@dkrz.de>
16 ! Thomas Jahns <jahns@dkrz.de>
17 ! URL: https://doc.redmine.dkrz.de/yaxt/html/
18 !
19 ! Redistribution and use in source and binary forms, with or without
20 ! modification, are permitted provided that the following conditions are
21 ! met:
22 !
23 ! Redistributions of source code must retain the above copyright notice,
24 ! this list of conditions and the following disclaimer.
25 !
26 ! Redistributions in binary form must reproduce the above copyright
27 ! notice, this list of conditions and the following disclaimer in the
28 ! documentation and/or other materials provided with the distribution.
29 !
30 ! Neither the name of the DKRZ GmbH nor the names of its contributors
31 ! may be used to endorse or promote products derived from this software
32 ! without specific prior written permission.
33 !
34 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
35 ! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
36 ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
37 ! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
38 ! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
39 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
40 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
41 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
42 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
43 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
44 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
45 !
46 PROGRAM test_xmap_all2all_fail
47  USE mpi
48  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
49  USE test_idxlist_utils, ONLY: test_err_count
50  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, &
51  xt_idxlist, xt_idxlist_delete, xt_idxvec_new, &
55  xt_set_abort_handler, xt_restore_default_abort_hndl
56  IMPLICIT NONE
57  INTERFACE
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
62  END INTERFACE
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
66  CALL init_mpi
67  CALL xt_initialize(mpi_comm_world)
68  CALL mpi_comm_rank(mpi_comm_world, my_rank, ierror)
69  CALL parse_options
70  CALL test_xmap1(list_size)
71 
72  IF (test_err_count() /= 0) &
73  CALL test_abort("non-zero error count!", filename, __line__)
74  CALL xt_finalize
75  CALL finish_mpi
76 CONTAINS
77  SUBROUTINE shift_idx(idx, offset)
78  INTEGER(xt_int_kind), INTENT(inout) :: idx(:)
79  INTEGER(xt_int_kind), INTENT(in) :: offset
80  INTEGER :: i
81  DO i = 1, SIZE(idx)
82  idx(i) = idx(i) + int(my_rank, xi) * offset
83  END DO
84  END SUBROUTINE shift_idx
85 
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
89  TYPE(xt_xmap) :: xmap
90  INTEGER :: rank(1)
91  src_idxlist = xt_idxvec_new(src_index_list)
92  dst_idxlist = xt_idxvec_new(dst_index_list)
93 
94  CALL xt_set_abort_handler(xfail_abort)
95  xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
96  CALL xt_restore_default_abort_hndl
97  CALL xt_idxlist_delete(src_idxlist)
98  CALL xt_idxlist_delete(dst_idxlist)
99 
100  IF (xt_xmap_get_num_destinations(xmap) /= 1) &
101  CALL test_abort("error in xmap construction", filename, __line__)
102 
103  IF (xt_xmap_get_num_sources(xmap) /= 1) &
104  CALL test_abort("error in xt_xmap_get_num_sources", filename, __line__)
105  CALL xt_xmap_get_destination_ranks(xmap, rank)
106  IF (rank(1) /= my_rank) &
107  CALL test_abort("error in xt_xmap_get_destination_ranks", &
108  filename, __line__)
109 
110  CALL xt_xmap_get_source_ranks(xmap, rank)
111  IF (rank(1) /= my_rank) &
112  CALL test_abort("error in xt_xmap_get_source_ranks", &
113  filename, __line__)
114  CALL xt_xmap_delete(xmap)
115  END SUBROUTINE test_xmap
116 
117  SUBROUTINE test_xmap1(num_idx)
118  INTEGER, INTENT(in) :: num_idx
119  INTEGER :: i
120  INTEGER(xt_int_kind) :: src_index_list(num_idx), &
121  dst_index_list(num_idx)
122  DO i = 1, num_idx
123  src_index_list(i) = int(i, xi)
124  END DO
125  CALL shift_idx(src_index_list, int(num_idx, xi))
126  DO i = 1, num_idx
127  dst_index_list(i) = int(num_idx - i + 2, xi)
128  END DO
129  CALL shift_idx(dst_index_list, int(num_idx, xi))
130  ! note: this should fail because dst/src indices don't match
131  CALL test_xmap(src_index_list, dst_index_list)
132  END SUBROUTINE test_xmap1
133 
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()
139  i = 1
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', &
146  filename, __line__)
147  IF (optarg(1:arg_len) == "big") THEN
148  list_size = 1023
149  ELSE IF (optarg(1:arg_len) == "small") THEN
150  list_size = 7
151  ELSE
152  WRITE (0, *) 'arg to -s: ', optarg(1:arg_len)
153  CALL test_abort('incorrect argument to command-line option -s', &
154  filename, __line__)
155  END IF
156  i = i + 2
157  ELSE
158  WRITE (0, *) 'unexpected command-line argument parsing error: ', &
159  trim(optarg)
160  FLUSH(0)
161  CALL test_abort('unexpected command-line argument', &
162  filename, __line__)
163  END IF
164  END DO
165  END SUBROUTINE parse_options
166 
167 END PROGRAM test_xmap_all2all_fail
168 
169 SUBROUTINE xfail_abort(comm, msg, source, line)
170  USE iso_c_binding, ONLY: c_int
171  USE mpi
172  USE ftest_common, ONLY: posix_exit
173  INTEGER, INTENT(in) :: comm, line
174  CHARACTER(len=*), INTENT(in) :: msg, source
175  INTEGER :: ierror
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)'
179 #endif
180  FLUSH(0)
181  CALL mpi_abort(comm, 3, ierror)
182  CALL posix_exit(3_c_int)
183 END SUBROUTINE xfail_abort
184 
185 
186 !
187 ! Local Variables:
188 ! f90-continuation-indent: 5
189 ! coding: utf-8
190 ! indent-tabs-mode: nil
191 ! show-trailing-whitespace: t
192 ! require-trailing-newline: t
193 ! End:
194 !
Definition: yaxt.f90:49
void xt_initialize(MPI_Comm default_comm)
Definition: xt_init.c:70
void xt_finalize(void)
Definition: xt_init.c:89
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition: xt_idxlist.c:74
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
Definition: xt_idxvec.c:163
void xt_xmap_delete(Xt_xmap xmap)
Definition: xt_xmap.c:85
int xt_xmap_get_num_destinations(Xt_xmap xmap)
Definition: xt_xmap.c:60
int xt_xmap_get_num_sources(Xt_xmap xmap)
Definition: xt_xmap.c:65
void xt_xmap_get_source_ranks(Xt_xmap xmap, int *ranks)
Definition: xt_xmap.c:75
void xt_xmap_get_destination_ranks(Xt_xmap xmap, int *ranks)
Definition: xt_xmap.c:70
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)