Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_xmap_all2all_fail_f.f90
1!>
2!! @file test_xmap_all2all_fail_f.f90
3!!
4!! @copyright Copyright (C) 2016 Jörg Behrens <behrens@dkrz.de>
5!! Moritz Hanke <hanke@dkrz.de>
6!! Thomas Jahns <jahns@dkrz.de>
7!!
8!! @author Jörg Behrens <behrens@dkrz.de>
9!! Moritz Hanke <hanke@dkrz.de>
10!! Thomas Jahns <jahns@dkrz.de>
11!!
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://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
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#include "fc_feature_defs.inc"
47PROGRAM test_xmap_all2all_fail
48 USE iso_c_binding, ONLY: c_int
49 USE mpi
50 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
51 USE test_idxlist_utils, ONLY: test_err_count
52 USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, &
54 USE test_xmap_common, ONLY : test_self_xmap_construct
55 IMPLICIT NONE
56 INTERFACE
57 FUNCTION xmap_new_fail3(src_idxlist, dst_idxlist, comm) RESULT(xmap)
58#if __INTEL_COMPILER == 1500
59 USE yaxt, ONLY: xt_xmap, xt_idxlist
60#else
61 IMPORT :: xt_xmap, xt_idxlist
62#endif
63 TYPE(xt_xmap) :: xmap
64 TYPE(xt_idxlist), INTENT(in) :: src_idxlist, dst_idxlist
65 INTEGER, INTENT(in) :: comm
66 END FUNCTION xmap_new_fail3
67 END INTERFACE
68 INTEGER, PARAMETER :: xi = xt_int_kind
69 CHARACTER(len=*), PARAMETER :: filename = 'test_xmap_all2all_fail_f.f90'
70 INTEGER :: my_rank, ierror, list_size
71 CALL init_mpi
72 CALL xt_initialize(mpi_comm_world)
73 CALL mpi_comm_rank(mpi_comm_world, my_rank, ierror)
74 CALL parse_options
75 CALL test_xmap1(list_size, mpi_comm_world)
76
77 IF (test_err_count() /= 0) &
78 CALL test_abort("non-zero error count!", filename, __line__)
79 CALL xt_finalize
80 CALL finish_mpi
81CONTAINS
82 SUBROUTINE test_xmap1(num_idx, comm)
83 INTEGER, INTENT(in) :: num_idx, comm
84 TYPE(xt_stripe) :: src_stripe(1), dst_stripe(1)
85
86 ! soruce index list
87 src_stripe(1)%nstrides = int(num_idx, c_int)
88 src_stripe(1)%start = 1_xi + int(my_rank, xi) * int(num_idx, xi)
89 src_stripe(1)%stride = 1_xi
90
91 ! destination index list
92 dst_stripe(1)%nstrides = int(num_idx, c_int)
93 dst_stripe(1)%start = src_stripe(1)%start + src_stripe(1)%nstrides
94 dst_stripe(1)%stride = -1_xi
95 ! note: this should fail because dst/src indices don't match
96 CALL test_self_xmap_construct(src_stripe, dst_stripe,&
97 & xmap_new_fail3, comm)
98 END SUBROUTINE test_xmap1
99
100 SUBROUTINE parse_options
101 INTEGER :: i, num_cmd_args, arg_len
102 INTEGER, PARAMETER :: max_opt_arg_len = 80
103 CHARACTER(max_opt_arg_len) :: optarg
104 num_cmd_args = command_argument_count()
105 i = 1
106 DO WHILE (i < num_cmd_args)
107 CALL get_command_argument(i, optarg, arg_len)
108 IF (optarg(1:2) == '-s' .AND. i < num_cmd_args .AND. arg_len == 2) THEN
109 CALL get_command_argument(i + 1, optarg, arg_len)
110 IF (arg_len > max_opt_arg_len) &
111 CALL test_abort('incorrect argument to command-line option -s', &
112 filename, __line__)
113 IF (optarg(1:arg_len) == "big") THEN
114 list_size = 1023
115 ELSE IF (optarg(1:arg_len) == "small") THEN
116 list_size = 7
117 ELSE
118 WRITE (0, *) 'arg to -s: ', optarg(1:arg_len)
119 CALL test_abort('incorrect argument to command-line option -s', &
120 filename, __line__)
121 END IF
122 i = i + 2
123 ELSE
124 WRITE (0, *) 'unexpected command-line argument parsing error: ', &
125 optarg(1:arg_len)
126 FLUSH(0)
127 CALL test_abort('unexpected command-line argument', &
128 filename, __line__)
129 END IF
130 END DO
131 END SUBROUTINE parse_options
132
133END PROGRAM test_xmap_all2all_fail
134
135SUBROUTINE xfail_abort(comm, msg, source, line)
136 USE iso_c_binding, ONLY: c_int
137 USE mpi
138 USE ftest_common, ONLY: posix_exit
139 INTEGER, INTENT(in) :: comm, line
140 CHARACTER(len=*), INTENT(in) :: msg, source
141 INTEGER :: ierror
142#ifdef XT_NEED_MPI_ABORT_WORK_AROUND
143 INTEGER :: abort_msg_lun
144#endif
145 WRITE (0, '(4a,i0)') msg, ' at ', source, ', line ', line
146
147#ifdef XT_NEED_MPI_ABORT_WORK_AROUND
148# if XT_NEED_MPI_ABORT_WORK_AROUND == 1
149 abort_msg_lun = 0
150# elif XT_NEED_MPI_ABORT_WORK_AROUND == 2
151 FLUSH(0)
152 abort_msg_lun = 10
153 OPEN(unit=abort_msg_lun, status='replace', &
154 file='test_xmap_all2all_fail.result.txt', &
155 action='write', iostat=ierror)
156# endif
157 WRITE (abort_msg_lun, '(a)') 'MPI_Abort(0xdeadbeef, 3)'
158 FLUSH(abort_msg_lun)
159#endif
160
161 CALL mpi_abort(comm, 3, ierror)
162 CALL posix_exit(3_c_int)
163END SUBROUTINE xfail_abort
164
165FUNCTION xmap_new_fail3(src_idxlist, dst_idxlist, comm) RESULT(xmap)
166 USE yaxt, ONLY: xt_xmap, xt_idxlist, xt_xmap_all2all_new, &
167 xt_set_abort_handler, xt_restore_default_abort_hndl
168 TYPE(xt_xmap) :: xmap
169 TYPE(xt_idxlist), INTENT(in) :: src_idxlist, dst_idxlist
170 INTEGER, INTENT(in) :: comm
171 INTERFACE
172 SUBROUTINE xfail_abort(comm, msg, source, line)
173 INTEGER, INTENT(in) :: comm, line
174 CHARACTER(len=*), INTENT(in) :: msg, source
175 END SUBROUTINE xfail_abort
176 END INTERFACE
177 CALL xt_set_abort_handler(xfail_abort)
178 xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, comm)
179 CALL xt_restore_default_abort_hndl
180END FUNCTION xmap_new_fail3
181
182!
183! Local Variables:
184! f90-continuation-indent: 5
185! coding: utf-8
186! indent-tabs-mode: nil
187! show-trailing-whitespace: t
188! require-trailing-newline: t
189! End:
190!
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)