Yet Another eXchange Tool  0.9.0
test_xmap_common_f.f90
1 
13 
14 !
15 ! Keywords:
16 ! Maintainer: Jörg Behrens <behrens@dkrz.de>
17 ! Moritz Hanke <hanke@dkrz.de>
18 ! Thomas Jahns <jahns@dkrz.de>
19 ! URL: https://doc.redmine.dkrz.de/yaxt/html/
20 !
21 ! Redistribution and use in source and binary forms, with or without
22 ! modification, are permitted provided that the following conditions are
23 ! met:
24 !
25 ! Redistributions of source code must retain the above copyright notice,
26 ! this list of conditions and the following disclaimer.
27 !
28 ! Redistributions in binary form must reproduce the above copyright
29 ! notice, this list of conditions and the following disclaimer in the
30 ! documentation and/or other materials provided with the distribution.
31 !
32 ! Neither the name of the DKRZ GmbH nor the names of its contributors
33 ! may be used to endorse or promote products derived from this software
34 ! without specific prior written permission.
35 !
36 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
37 ! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
38 ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
39 ! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
40 ! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
41 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
42 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
43 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
44 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
45 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
46 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
47 !
48 MODULE test_xmap_common
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, &
53  xt_idxlist, xt_idxlist_delete, xt_idxvec_new, &
54  xt_xmap, xt_xmap_copy, xt_xmap_delete, &
58  IMPLICIT NONE
59  PRIVATE
60  INTEGER :: my_rank
61  INTEGER, PARAMETER :: xi = xt_int_kind
62  PUBLIC :: xmap_self_test_main
63  CHARACTER(len=*), PARAMETER :: filename = 'test_xmap_common_f.f90'
64 CONTAINS
65  SUBROUTINE xmap_self_test_main(xmap_new)
66  INTERFACE
67  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
68  IMPORT :: xt_idxlist, xt_xmap
69  IMPLICIT NONE
70  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
71  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
72  INTEGER, VALUE, INTENT(in) :: comm
73  TYPE(xt_xmap) :: res
74  END FUNCTION xmap_new
75  END INTERFACE
76  INTEGER :: ierror, i
77  INTEGER :: comms(2)
78 
79  CALL init_mpi
80  CALL xt_initialize(mpi_comm_world)
81  CALL mpi_comm_rank(mpi_comm_world, my_rank, ierror)
82  IF (ierror /= mpi_success) &
83  CALL test_abort("MPI error!", filename, __line__)
84 
85  comms(1) = mpi_comm_world
86  CALL mpi_comm_dup(mpi_comm_world, comms(2), ierror)
87  IF (ierror /= mpi_success) &
88  CALL test_abort("MPI error!", filename, __line__)
89  CALL xt_mpi_comm_mark_exclusive(comms(2))
90 
91  DO i = 1, SIZE(comms)
92  CALL test_xmap1(xmap_new, comms(i))
93  CALL test_xmap2(xmap_new, comms(i))
94  END DO
95 
96  CALL mpi_comm_free(comms(2), ierror)
97  IF (ierror /= mpi_success) &
98  CALL test_abort("MPI error!", filename, __line__)
99 
100  IF (test_err_count() /= 0) &
101  CALL test_abort("non-zero error count!", filename, __line__)
102  CALL xt_finalize
103  CALL finish_mpi
104  END SUBROUTINE xmap_self_test_main
105 
106  SUBROUTINE shift_idx(idx, offset)
107  INTEGER(xt_int_kind), INTENT(inout) :: idx(:)
108  INTEGER(xt_int_kind), INTENT(in) :: offset
109  INTEGER :: i
110  DO i = 1, SIZE(idx)
111  idx(i) = idx(i) + int(my_rank, xi) * offset
112  END DO
113  END SUBROUTINE shift_idx
114 
115  SUBROUTINE assert_xmap_is_to_self(xmap)
116  TYPE(xt_xmap) :: xmap
117  INTEGER :: rank(1)
118  IF (xt_xmap_get_num_destinations(xmap) /= 1) &
119  CALL test_abort("error in xmap construction", filename, __line__)
120 
121  IF (xt_xmap_get_num_sources(xmap) /= 1) &
122  CALL test_abort("error in xt_xmap_get_num_sources", filename, __line__)
123  CALL xt_xmap_get_destination_ranks(xmap, rank)
124  IF (rank(1) /= my_rank) &
125  CALL test_abort("error in xt_xmap_get_destination_ranks", &
126  filename, __line__)
127 
128  CALL xt_xmap_get_source_ranks(xmap, rank)
129  IF (rank(1) /= my_rank) &
130  CALL test_abort("error in xt_xmap_get_source_ranks", &
131  filename, __line__)
132 
133  END SUBROUTINE assert_xmap_is_to_self
134 
135  SUBROUTINE test_xmap(src_index_list, dst_index_list, xmap_new, comm)
136  INTEGER(xt_int_kind), INTENT(in) :: src_index_list(:), dst_index_list(:)
137  TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
138  INTERFACE
139  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
140  IMPORT :: xt_idxlist, xt_xmap
141  IMPLICIT NONE
142  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
143  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
144  INTEGER, VALUE, INTENT(in) :: comm
145  TYPE(xt_xmap) :: res
146  END FUNCTION xmap_new
147  END INTERFACE
148  INTEGER, INTENT(inout) :: comm
149 
150  TYPE(xt_xmap) :: xmap, xmap_copy
151  src_idxlist = xt_idxvec_new(src_index_list)
152  dst_idxlist = xt_idxvec_new(dst_index_list)
153 
154  xmap = xmap_new(src_idxlist, dst_idxlist, comm)
155  CALL xt_idxlist_delete(src_idxlist)
156  CALL xt_idxlist_delete(dst_idxlist)
157 
158  CALL assert_xmap_is_to_self(xmap)
159  xmap_copy = xt_xmap_copy(xmap)
160  CALL assert_xmap_is_to_self(xmap_copy)
161 
162  CALL xt_xmap_delete(xmap)
163  CALL xt_xmap_delete(xmap_copy)
164  END SUBROUTINE test_xmap
165 
166  SUBROUTINE test_xmap1(xmap_new, comm)
167  INTERFACE
168  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
169  IMPORT :: xt_idxlist, xt_xmap
170  IMPLICIT NONE
171  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
172  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
173  INTEGER, VALUE, INTENT(in) :: comm
174  TYPE(xt_xmap) :: res
175  END FUNCTION xmap_new
176  END INTERFACE
177  INTEGER, INTENT(inout) :: comm
178 
179  INTEGER(xt_int_kind) :: i
180  INTEGER(xt_int_kind), PARAMETER :: num_src_idx = 7, num_dst_idx = 7
181  INTEGER(xt_int_kind) :: src_index_list(num_src_idx), &
182  dst_index_list(num_dst_idx)
183  DO i = 1_xi, num_src_idx
184  src_index_list(i) = i
185  END DO
186  CALL shift_idx(src_index_list, num_src_idx)
187  DO i = 1_xi, num_dst_idx
188  dst_index_list(i) = num_dst_idx - i + 1_xi
189  END DO
190  CALL shift_idx(dst_index_list, num_src_idx)
191  CALL test_xmap(src_index_list, dst_index_list, xmap_new, comm)
192  END SUBROUTINE test_xmap1
193 
194  SUBROUTINE test_xmap2(xmap_new, comm)
195  INTERFACE
196  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
197  IMPORT :: xt_idxlist, xt_xmap
198  IMPLICIT NONE
199  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
200  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
201  INTEGER, VALUE, INTENT(in) :: comm
202  TYPE(xt_xmap) :: res
203  END FUNCTION xmap_new
204  END INTERFACE
205  INTEGER, INTENT(inout) :: comm
206 
207  INTEGER(xt_int_kind) :: src_index_list(14), dst_index_list(13)
208  src_index_list = &
209  (/ 5_xi, 67_xi, 4_xi, 5_xi, 13_xi, &
210  & 9_xi, 2_xi, 1_xi, 0_xi, 96_xi, &
211  & 13_xi, 12_xi, 1_xi, 3_xi /)
212  dst_index_list = &
213  (/ 5_xi, 4_xi, 3_xi, 96_xi, 1_xi, &
214  & 5_xi, 4_xi, 5_xi, 4_xi, 3_xi, &
215  & 13_xi, 2_xi, 1_xi /)
216  CALL test_xmap(src_index_list, dst_index_list, xmap_new, comm)
217  END SUBROUTINE test_xmap2
218 
219 END MODULE test_xmap_common
220 !
221 ! Local Variables:
222 ! f90-continuation-indent: 5
223 ! coding: utf-8
224 ! indent-tabs-mode: nil
225 ! show-trailing-whitespace: t
226 ! require-trailing-newline: t
227 ! End:
228 !
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_mpi_comm_mark_exclusive(MPI_Comm comm)
Definition: xt_mpi.c:881
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
Xt_xmap xt_xmap_copy(Xt_xmap xmap)
Definition: xt_xmap.c:80
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