Yet Another eXchange Tool  0.9.0
test_redist_single_array_base_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_redist_single_array_base_f
47  USE mpi
48  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_redist_msg, &
49  xt_config, xt_config_delete
50 
51  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
52  USE test_redist_common, ONLY: communicators_are_congruent, &
53  test_redist_single_array_base, redist_exchanger_option
54  USE test_idxlist_utils, ONLY: test_err_count
55  IMPLICIT NONE
56  CHARACTER(len=*), PARAMETER :: &
57  filename = 'test_redist_single_array_base_f.f90'
58  TYPE(xt_config) :: config
59 
60  ! init mpi
61  CALL init_mpi
62 
63  CALL xt_initialize(mpi_comm_world)
64  config = redist_exchanger_option()
65 
66  ! single double
67  CALL test_single_double(mpi_comm_world, config)
68  ! reverse order of some doubles
69  CALL test_reverse_doubles(mpi_comm_world, config)
70 
71  IF (test_err_count() /= 0) &
72  CALL test_abort("non-zero error count!", filename, __line__)
73 
74  CALL xt_config_delete(config)
75  CALL xt_finalize
76  CALL finish_mpi
77 
78 CONTAINS
79 
80  SUBROUTINE test_single_double(comm, config)
81  INTEGER, INTENT(in) :: comm
82  TYPE(xt_config), INTENT(in) :: config
83 
84 
85  TYPE(xt_redist_msg) :: send_msgs(1)
86  TYPE(xt_redist_msg) :: recv_msgs(1)
87 
88  INTEGER, PARAMETER :: num_elem = 1
89  DOUBLE PRECISION, PARAMETER :: src_data(num_elem) &
90  = (/ 0.0d0 /)
91  DOUBLE PRECISION, PARAMETER :: ref_dst_data(num_elem) &
92  = (/ 0.0d0 /)
93 
94  send_msgs(1)%rank = 0
95  send_msgs(1)%datatype = mpi_double_precision
96  recv_msgs(1)%rank = 0
97  recv_msgs(1)%datatype = mpi_double_precision
98 
99  CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
100  ref_dst_data, comm, config)
101 
102  END SUBROUTINE test_single_double
103 
104  SUBROUTINE test_reverse_doubles(comm, config)
105  INTEGER, INTENT(in) :: comm
106  TYPE(xt_config), INTENT(in) :: config
107 
108 
109  TYPE(xt_redist_msg) :: send_msgs(1)
110  TYPE(xt_redist_msg) :: recv_msgs(1)
111 
112  INTEGER :: i, ierror
113  INTEGER, PARAMETER :: num_elem = 10
114  INTEGER, PARAMETER :: displ(num_elem) &
115  = (/ (i, i = num_elem - 1, 0, -1) /)
116 #ifndef __PGI
117  DOUBLE PRECISION, PARAMETER :: src_data(num_elem) &
118  = (/ (dble(i), i = 1, num_elem) /)
119  DOUBLE PRECISION, PARAMETER :: ref_dst_data(num_elem) &
120  = (/ (dble(i), i = num_elem, 1, -1) /)
121 #else
122  DOUBLE PRECISION :: src_data(num_elem), ref_dst_data(num_elem)
123 #endif
124 
125 #ifdef __PGI
126  DO i = 1, num_elem
127  src_data(i) = dble(i)
128  ref_dst_data(i) = dble(num_elem - i + 1)
129  END DO
130 #endif
131  send_msgs(1)%rank = 0
132  CALL mpi_type_contiguous( &
133  num_elem, mpi_double_precision, send_msgs(1)%datatype, ierror)
134  IF (ierror /= mpi_success) &
135  CALL test_abort("error calling mpi_type_contiguous", &
136  filename, __line__)
137  CALL mpi_type_commit(send_msgs(1)%datatype, ierror)
138  IF (ierror /= mpi_success) &
139  CALL test_abort("error calling mpi_type_commit", &
140  filename, __line__)
141  recv_msgs(1)%rank = 0
142  CALL mpi_type_create_indexed_block(num_elem, 1, displ, &
143  mpi_double_precision, recv_msgs(1)%datatype, ierror)
144  IF (ierror /= mpi_success) &
145  CALL test_abort("error calling mpi_type_create_indexed_block", &
146  filename, __line__)
147  CALL mpi_type_commit(recv_msgs(1)%datatype, ierror)
148  IF (ierror /= mpi_success) &
149  CALL test_abort("error calling mpi_type_commit", &
150  filename, __line__)
151 
152  CALL test_redist_single_array_base(send_msgs, recv_msgs, src_data, &
153  ref_dst_data, comm, config)
154 
155  CALL mpi_type_free(recv_msgs(1)%datatype, ierror)
156  IF (ierror /= mpi_success) &
157  CALL test_abort("error calling mpi_type_free", filename, __line__)
158  CALL mpi_type_free(send_msgs(1)%datatype, ierror)
159  IF (ierror /= mpi_success) &
160  CALL test_abort("error calling mpi_type_free", filename, __line__)
161 
162  END SUBROUTINE test_reverse_doubles
163 
164 END PROGRAM test_redist_single_array_base_f
165 !
166 ! Local Variables:
167 ! f90-continuation-indent: 5
168 ! coding: utf-8
169 ! indent-tabs-mode: nil
170 ! show-trailing-whitespace: t
171 ! require-trailing-newline: t
172 ! End:
173 !
Definition: yaxt.f90:49
void xt_config_delete(Xt_config config)
Definition: xt_config.c:76
void xt_initialize(MPI_Comm default_comm)
Definition: xt_init.c:70
void xt_finalize(void)
Definition: xt_init.c:89