Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2025 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Interface to the message passing library MPI
10 : !> \par History
11 : !> JGH (02-Jan-2001): New error handling
12 : !> Performance tools
13 : !> JGH (14-Jan-2001): New routines mp_comm_compare, mp_cart_coords,
14 : !> mp_rank_compare, mp_alltoall
15 : !> JGH (06-Feb-2001): New routines mp_comm_free
16 : !> JGH (22-Mar-2001): New routines mp_comm_dup
17 : !> fawzi (04-NOV-2004): storable performance info (for f77 interface)
18 : !> Wrapper routine for mpi_gatherv added (22.12.2005,MK)
19 : !> JGH (13-Feb-2006): Flexible precision
20 : !> JGH (15-Feb-2006): single precision mp_alltoall
21 : !> \author JGH
22 : ! **************************************************************************************************
23 : MODULE message_passing
24 : USE ISO_C_BINDING, ONLY: C_F_POINTER, C_PTR
25 : USE kinds, ONLY: &
26 : dp, int_4, int_4_size, int_8, int_8_size, real_4, real_4_size, real_8, &
27 : real_8_size, default_string_length
28 : USE machine, ONLY: m_abort
29 : USE mp_perf_env, ONLY: add_perf, add_mp_perf_env, rm_mp_perf_env
30 :
31 : #include "../base/base_uses.f90"
32 :
33 : ! To simplify the transition between the old MPI module and the F08-style module, we introduce these constants to switch between the required handle types
34 : ! Unfortunately, Fortran does not offer something like typedef in C++
35 : #if defined(__parallel) && defined(__MPI_F08)
36 : #define MPI_DATA_TYPE TYPE(MPI_Datatype)
37 : #define MPI_COMM_TYPE TYPE(MPI_Comm)
38 : #define MPI_REQUEST_TYPE TYPE(MPI_Request)
39 : #define MPI_WIN_TYPE TYPE(MPI_Win)
40 : #define MPI_FILE_TYPE TYPE(MPI_File)
41 : #define MPI_INFO_TYPE TYPE(MPI_Info)
42 : #define MPI_STATUS_TYPE TYPE(MPI_Status)
43 : #define MPI_GROUP_TYPE TYPE(MPI_Group)
44 : #define MPI_STATUS_EXTRACT(X) %X
45 : #define MPI_GET_COMP %mpi_val
46 : #else
47 : #define MPI_DATA_TYPE INTEGER
48 : #define MPI_COMM_TYPE INTEGER
49 : #define MPI_REQUEST_TYPE INTEGER
50 : #define MPI_WIN_TYPE INTEGER
51 : #define MPI_FILE_TYPE INTEGER
52 : #define MPI_INFO_TYPE INTEGER
53 : #define MPI_STATUS_TYPE INTEGER, DIMENSION(MPI_STATUS_SIZE)
54 : #define MPI_GROUP_TYPE INTEGER
55 : #define MPI_STATUS_EXTRACT(X) (X)
56 : #define MPI_GET_COMP
57 : #endif
58 :
59 : #if defined(__parallel)
60 : ! subroutines: unfortunately, mpi implementations do not provide interfaces for all subroutines (problems with types and ranks explosion),
61 : ! we do not quite know what is in the module, so we can not include any....
62 : ! to nevertheless get checking for what is included, we use the mpi module without use clause, getting all there is
63 : #if defined(__MPI_F08)
64 : USE mpi_f08
65 : #else
66 : USE mpi
67 : #endif
68 : #endif
69 : IMPLICIT NONE
70 : PRIVATE
71 :
72 : ! parameters that might be needed
73 : #if defined(__parallel)
74 : LOGICAL, PARAMETER :: cp2k_is_parallel = .TRUE.
75 : INTEGER, PARAMETER, PUBLIC :: mp_any_tag = MPI_ANY_TAG
76 : INTEGER, PARAMETER, PUBLIC :: mp_any_source = MPI_ANY_SOURCE
77 : MPI_COMM_TYPE, PARAMETER :: mp_comm_null_handle = MPI_COMM_NULL
78 : MPI_COMM_TYPE, PARAMETER :: mp_comm_self_handle = MPI_COMM_SELF
79 : MPI_COMM_TYPE, PARAMETER :: mp_comm_world_handle = MPI_COMM_WORLD
80 : MPI_REQUEST_TYPE, PARAMETER :: mp_request_null_handle = MPI_REQUEST_NULL
81 : MPI_WIN_TYPE, PARAMETER :: mp_win_null_handle = MPI_WIN_NULL
82 : MPI_FILE_TYPE, PARAMETER :: mp_file_null_handle = MPI_FILE_NULL
83 : MPI_INFO_TYPE, PARAMETER :: mp_info_null_handle = MPI_INFO_NULL
84 : MPI_DATA_TYPE, PARAMETER :: mp_datatype_null_handle = MPI_DATATYPE_NULL
85 : INTEGER, PARAMETER, PUBLIC :: mp_status_size = MPI_STATUS_SIZE
86 : INTEGER, PARAMETER, PUBLIC :: mp_proc_null = MPI_PROC_NULL
87 : ! Set max allocatable memory by MPI to 2 GiByte
88 : INTEGER(KIND=MPI_ADDRESS_KIND), PARAMETER, PRIVATE :: mp_max_memory_size = HUGE(INT(1, KIND=int_4))
89 :
90 : INTEGER, PARAMETER, PUBLIC :: mp_max_library_version_string = MPI_MAX_LIBRARY_VERSION_STRING
91 :
92 : INTEGER, PARAMETER, PUBLIC :: file_offset = MPI_OFFSET_KIND
93 : INTEGER, PARAMETER, PUBLIC :: address_kind = MPI_ADDRESS_KIND
94 : INTEGER, PARAMETER, PUBLIC :: file_amode_create = MPI_MODE_CREATE
95 : INTEGER, PARAMETER, PUBLIC :: file_amode_rdonly = MPI_MODE_RDONLY
96 : INTEGER, PARAMETER, PUBLIC :: file_amode_wronly = MPI_MODE_WRONLY
97 : INTEGER, PARAMETER, PUBLIC :: file_amode_rdwr = MPI_MODE_RDWR
98 : INTEGER, PARAMETER, PUBLIC :: file_amode_excl = MPI_MODE_EXCL
99 : INTEGER, PARAMETER, PUBLIC :: file_amode_append = MPI_MODE_APPEND
100 : #else
101 : LOGICAL, PARAMETER :: cp2k_is_parallel = .FALSE.
102 : INTEGER, PARAMETER, PUBLIC :: mp_any_tag = -1
103 : INTEGER, PARAMETER, PUBLIC :: mp_any_source = -2
104 : MPI_COMM_TYPE, PARAMETER :: mp_comm_null_handle = -3
105 : MPI_COMM_TYPE, PARAMETER :: mp_comm_self_handle = -11
106 : MPI_COMM_TYPE, PARAMETER :: mp_comm_world_handle = -12
107 : MPI_REQUEST_TYPE, PARAMETER :: mp_request_null_handle = -4
108 : MPI_WIN_TYPE, PARAMETER :: mp_win_null_handle = -5
109 : MPI_FILE_TYPE, PARAMETER :: mp_file_null_handle = -6
110 : MPI_INFO_TYPE, PARAMETER :: mp_info_null_handle = -7
111 : MPI_DATA_TYPE, PARAMETER :: mp_datatype_null_handle = -8
112 : INTEGER, PARAMETER, PUBLIC :: mp_status_size = -9
113 : INTEGER, PARAMETER, PUBLIC :: mp_proc_null = -10
114 : INTEGER, PARAMETER, PUBLIC :: mp_max_library_version_string = 1
115 :
116 : INTEGER, PARAMETER, PUBLIC :: file_offset = int_8
117 : INTEGER, PARAMETER, PUBLIC :: address_kind = int_8
118 : INTEGER, PARAMETER, PUBLIC :: file_amode_create = 1
119 : INTEGER, PARAMETER, PUBLIC :: file_amode_rdonly = 2
120 : INTEGER, PARAMETER, PUBLIC :: file_amode_wronly = 4
121 : INTEGER, PARAMETER, PUBLIC :: file_amode_rdwr = 8
122 : INTEGER, PARAMETER, PUBLIC :: file_amode_excl = 64
123 : INTEGER, PARAMETER, PUBLIC :: file_amode_append = 128
124 : #endif
125 :
126 : ! we need to fix this to a given number (crossing fingers)
127 : ! so that the serial code using Fortran stream IO and the MPI have the same sizes.
128 : INTEGER, PARAMETER, PUBLIC :: mpi_character_size = 1
129 : INTEGER, PARAMETER, PUBLIC :: mpi_integer_size = 4
130 :
131 : CHARACTER(LEN=*), PARAMETER, PRIVATE :: moduleN = 'message_passing'
132 :
133 : ! internal reference counter used to debug communicator leaks
134 : INTEGER, PRIVATE, SAVE :: debug_comm_count
135 :
136 : PUBLIC :: mp_comm_type
137 : PUBLIC :: mp_request_type
138 : PUBLIC :: mp_win_type
139 : PUBLIC :: mp_file_type
140 : PUBLIC :: mp_info_type
141 : PUBLIC :: mp_cart_type
142 :
143 : PUBLIC :: mp_para_env_type, mp_para_env_p_type, mp_para_cart_type
144 : PUBLIC :: mp_para_env_create, mp_para_env_release, &
145 : mp_para_cart_create, mp_para_cart_release
146 :
147 : TYPE mp_comm_type
148 : PRIVATE
149 : MPI_COMM_TYPE :: handle = mp_comm_null_handle
150 : ! Number of dimensions within a Cartesian topology (useful with mp_cart_type)
151 : INTEGER :: ndims = 1
152 : ! Meta data to the communicator
153 : INTEGER, PUBLIC :: mepos = -1, source = -1, num_pe = -1
154 : CONTAINS
155 : ! Setters/Getters
156 : PROCEDURE, PASS, NON_OVERRIDABLE :: set_handle => mp_comm_type_set_handle
157 : PROCEDURE, PASS, NON_OVERRIDABLE :: get_handle => mp_comm_type_get_handle
158 : ! Comparisons
159 : PROCEDURE, PRIVATE, PASS, NON_OVERRIDABLE :: mp_comm_op_eq
160 : PROCEDURE, PRIVATE, PASS, NON_OVERRIDABLE :: mp_comm_op_neq
161 : GENERIC, PUBLIC :: operator(==) => mp_comm_op_eq
162 : GENERIC, PUBLIC :: operator(/=) => mp_comm_op_neq
163 : ! Communication routines
164 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: &
165 : mp_sendrecv_i, mp_sendrecv_l, mp_sendrecv_r, mp_sendrecv_d, &
166 : mp_sendrecv_c, mp_sendrecv_z, &
167 : mp_sendrecv_iv, mp_sendrecv_im2, mp_sendrecv_im3, mp_sendrecv_im4, &
168 : mp_sendrecv_lv, mp_sendrecv_lm2, mp_sendrecv_lm3, mp_sendrecv_lm4, &
169 : mp_sendrecv_rv, mp_sendrecv_rm2, mp_sendrecv_rm3, mp_sendrecv_rm4, &
170 : mp_sendrecv_dv, mp_sendrecv_dm2, mp_sendrecv_dm3, mp_sendrecv_dm4, &
171 : mp_sendrecv_cv, mp_sendrecv_cm2, mp_sendrecv_cm3, mp_sendrecv_cm4, &
172 : mp_sendrecv_zv, mp_sendrecv_zm2, mp_sendrecv_zm3, mp_sendrecv_zm4
173 : GENERIC, PUBLIC :: sendrecv => mp_sendrecv_i, mp_sendrecv_l, &
174 : mp_sendrecv_r, mp_sendrecv_d, mp_sendrecv_c, mp_sendrecv_z, &
175 : mp_sendrecv_iv, mp_sendrecv_im2, mp_sendrecv_im3, mp_sendrecv_im4, &
176 : mp_sendrecv_lv, mp_sendrecv_lm2, mp_sendrecv_lm3, mp_sendrecv_lm4, &
177 : mp_sendrecv_rv, mp_sendrecv_rm2, mp_sendrecv_rm3, mp_sendrecv_rm4, &
178 : mp_sendrecv_dv, mp_sendrecv_dm2, mp_sendrecv_dm3, mp_sendrecv_dm4, &
179 : mp_sendrecv_cv, mp_sendrecv_cm2, mp_sendrecv_cm3, mp_sendrecv_cm4, &
180 : mp_sendrecv_zv, mp_sendrecv_zm2, mp_sendrecv_zm3, mp_sendrecv_zm4
181 :
182 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_minloc_iv, &
183 : mp_minloc_lv, mp_minloc_rv, mp_minloc_dv
184 : GENERIC, PUBLIC :: minloc => mp_minloc_iv, &
185 : mp_minloc_lv, mp_minloc_rv, mp_minloc_dv
186 :
187 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_maxloc_iv, &
188 : mp_maxloc_lv, mp_maxloc_rv, mp_maxloc_dv
189 : GENERIC, PUBLIC :: maxloc => mp_maxloc_iv, &
190 : mp_maxloc_lv, mp_maxloc_rv, mp_maxloc_dv
191 :
192 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_shift_im, mp_shift_i, &
193 : mp_shift_lm, mp_shift_l, mp_shift_rm, mp_shift_r, &
194 : mp_shift_dm, mp_shift_d, mp_shift_cm, mp_shift_c, &
195 : mp_shift_zm, mp_shift_z
196 : GENERIC, PUBLIC :: shift => mp_shift_im, mp_shift_i, &
197 : mp_shift_lm, mp_shift_l, mp_shift_rm, mp_shift_r, &
198 : mp_shift_dm, mp_shift_d, mp_shift_cm, mp_shift_c, &
199 : mp_shift_zm, mp_shift_z
200 :
201 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_bcast_i, mp_bcast_iv, mp_bcast_im, mp_bcast_i3, &
202 : mp_bcast_l, mp_bcast_lv, mp_bcast_lm, mp_bcast_l3, &
203 : mp_bcast_r, mp_bcast_rv, mp_bcast_rm, mp_bcast_r3, &
204 : mp_bcast_d, mp_bcast_dv, mp_bcast_dm, mp_bcast_d3, &
205 : mp_bcast_c, mp_bcast_cv, mp_bcast_cm, mp_bcast_c3, &
206 : mp_bcast_z, mp_bcast_zv, mp_bcast_zm, mp_bcast_z3, &
207 : mp_bcast_b, mp_bcast_bv, mp_bcast_av, mp_bcast_am, &
208 : mp_bcast_i_src, mp_bcast_iv_src, mp_bcast_im_src, mp_bcast_i3_src, &
209 : mp_bcast_l_src, mp_bcast_lv_src, mp_bcast_lm_src, mp_bcast_l3_src, &
210 : mp_bcast_r_src, mp_bcast_rv_src, mp_bcast_rm_src, mp_bcast_r3_src, &
211 : mp_bcast_d_src, mp_bcast_dv_src, mp_bcast_dm_src, mp_bcast_d3_src, &
212 : mp_bcast_c_src, mp_bcast_cv_src, mp_bcast_cm_src, mp_bcast_c3_src, &
213 : mp_bcast_z_src, mp_bcast_zv_src, mp_bcast_zm_src, mp_bcast_z3_src, &
214 : mp_bcast_b_src, mp_bcast_bv_src, mp_bcast_av_src, mp_bcast_am_src
215 : GENERIC, PUBLIC :: bcast => mp_bcast_i, mp_bcast_iv, mp_bcast_im, mp_bcast_i3, &
216 : mp_bcast_l, mp_bcast_lv, mp_bcast_lm, mp_bcast_l3, &
217 : mp_bcast_r, mp_bcast_rv, mp_bcast_rm, mp_bcast_r3, &
218 : mp_bcast_d, mp_bcast_dv, mp_bcast_dm, mp_bcast_d3, &
219 : mp_bcast_c, mp_bcast_cv, mp_bcast_cm, mp_bcast_c3, &
220 : mp_bcast_z, mp_bcast_zv, mp_bcast_zm, mp_bcast_z3, &
221 : mp_bcast_b, mp_bcast_bv, mp_bcast_av, mp_bcast_am, &
222 : mp_bcast_i_src, mp_bcast_iv_src, mp_bcast_im_src, mp_bcast_i3_src, &
223 : mp_bcast_l_src, mp_bcast_lv_src, mp_bcast_lm_src, mp_bcast_l3_src, &
224 : mp_bcast_r_src, mp_bcast_rv_src, mp_bcast_rm_src, mp_bcast_r3_src, &
225 : mp_bcast_d_src, mp_bcast_dv_src, mp_bcast_dm_src, mp_bcast_d3_src, &
226 : mp_bcast_c_src, mp_bcast_cv_src, mp_bcast_cm_src, mp_bcast_c3_src, &
227 : mp_bcast_z_src, mp_bcast_zv_src, mp_bcast_zm_src, mp_bcast_z3_src, &
228 : mp_bcast_b_src, mp_bcast_bv_src, mp_bcast_av_src, mp_bcast_am_src
229 :
230 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_ibcast_i, mp_ibcast_iv, &
231 : mp_ibcast_l, mp_ibcast_lv, mp_ibcast_r, mp_ibcast_rv, &
232 : mp_ibcast_d, mp_ibcast_dv, mp_ibcast_c, mp_ibcast_cv, &
233 : mp_ibcast_z, mp_ibcast_zv
234 : GENERIC, PUBLIC :: ibcast => mp_ibcast_i, mp_ibcast_iv, &
235 : mp_ibcast_l, mp_ibcast_lv, mp_ibcast_r, mp_ibcast_rv, &
236 : mp_ibcast_d, mp_ibcast_dv, mp_ibcast_c, mp_ibcast_cv, &
237 : mp_ibcast_z, mp_ibcast_zv
238 :
239 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: &
240 : mp_sum_i, mp_sum_iv, mp_sum_im, mp_sum_im3, mp_sum_im4, &
241 : mp_sum_l, mp_sum_lv, mp_sum_lm, mp_sum_lm3, mp_sum_lm4, &
242 : mp_sum_r, mp_sum_rv, mp_sum_rm, mp_sum_rm3, mp_sum_rm4, &
243 : mp_sum_d, mp_sum_dv, mp_sum_dm, mp_sum_dm3, mp_sum_dm4, &
244 : mp_sum_c, mp_sum_cv, mp_sum_cm, mp_sum_cm3, mp_sum_cm4, &
245 : mp_sum_z, mp_sum_zv, mp_sum_zm, mp_sum_zm3, mp_sum_zm4, &
246 : mp_sum_root_iv, mp_sum_root_im, mp_sum_root_lv, mp_sum_root_lm, &
247 : mp_sum_root_rv, mp_sum_root_rm, mp_sum_root_dv, mp_sum_root_dm, &
248 : mp_sum_root_cv, mp_sum_root_cm, mp_sum_root_zv, mp_sum_root_zm, &
249 : mp_sum_b, mp_sum_bv
250 : GENERIC, PUBLIC :: sum => mp_sum_i, mp_sum_iv, mp_sum_im, mp_sum_im3, mp_sum_im4, &
251 : mp_sum_l, mp_sum_lv, mp_sum_lm, mp_sum_lm3, mp_sum_lm4, &
252 : mp_sum_r, mp_sum_rv, mp_sum_rm, mp_sum_rm3, mp_sum_rm4, &
253 : mp_sum_d, mp_sum_dv, mp_sum_dm, mp_sum_dm3, mp_sum_dm4, &
254 : mp_sum_c, mp_sum_cv, mp_sum_cm, mp_sum_cm3, mp_sum_cm4, &
255 : mp_sum_z, mp_sum_zv, mp_sum_zm, mp_sum_zm3, mp_sum_zm4, &
256 : mp_sum_root_iv, mp_sum_root_im, mp_sum_root_lv, mp_sum_root_lm, &
257 : mp_sum_root_rv, mp_sum_root_rm, mp_sum_root_dv, mp_sum_root_dm, &
258 : mp_sum_root_cv, mp_sum_root_cm, mp_sum_root_zv, mp_sum_root_zm, &
259 : mp_sum_b, mp_sum_bv
260 :
261 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_isum_iv, &
262 : mp_isum_lv, mp_isum_rv, mp_isum_dv, mp_isum_cv, &
263 : mp_isum_zv, mp_isum_bv
264 : GENERIC, PUBLIC :: isum => mp_isum_iv, &
265 : mp_isum_lv, mp_isum_rv, mp_isum_dv, mp_isum_cv, &
266 : mp_isum_zv, mp_isum_bv
267 :
268 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_sum_partial_im, &
269 : mp_sum_partial_lm, mp_sum_partial_rm, mp_sum_partial_dm, &
270 : mp_sum_partial_cm, mp_sum_partial_zm
271 : GENERIC, PUBLIC :: sum_partial => mp_sum_partial_im, &
272 : mp_sum_partial_lm, mp_sum_partial_rm, mp_sum_partial_dm, &
273 : mp_sum_partial_cm, mp_sum_partial_zm
274 :
275 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_max_i, mp_max_iv, &
276 : mp_max_l, mp_max_lv, mp_max_r, mp_max_rv, &
277 : mp_max_d, mp_max_dv, mp_max_c, mp_max_cv, &
278 : mp_max_z, mp_max_zv, mp_max_root_i, mp_max_root_l, &
279 : mp_max_root_r, mp_max_root_d, mp_max_root_c, mp_max_root_z, &
280 : mp_max_root_im, mp_max_root_lm, mp_max_root_rm, mp_max_root_dm, &
281 : mp_max_root_cm, mp_max_root_zm
282 : GENERIC, PUBLIC :: max => mp_max_i, mp_max_iv, &
283 : mp_max_l, mp_max_lv, mp_max_r, mp_max_rv, &
284 : mp_max_d, mp_max_dv, mp_max_c, mp_max_cv, &
285 : mp_max_z, mp_max_zv, mp_max_root_i, mp_max_root_l, &
286 : mp_max_root_r, mp_max_root_d, mp_max_root_c, mp_max_root_z, &
287 : mp_max_root_im, mp_max_root_lm, mp_max_root_rm, mp_max_root_dm, &
288 : mp_max_root_cm, mp_max_root_zm
289 :
290 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_min_i, mp_min_iv, &
291 : mp_min_l, mp_min_lv, mp_min_r, mp_min_rv, &
292 : mp_min_d, mp_min_dv, mp_min_c, mp_min_cv, &
293 : mp_min_z, mp_min_zv
294 : GENERIC, PUBLIC :: min => mp_min_i, mp_min_iv, &
295 : mp_min_l, mp_min_lv, mp_min_r, mp_min_rv, &
296 : mp_min_d, mp_min_dv, mp_min_c, mp_min_cv, &
297 : mp_min_z, mp_min_zv
298 :
299 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: &
300 : mp_sum_scatter_iv, mp_sum_scatter_lv, mp_sum_scatter_rv, &
301 : mp_sum_scatter_dv, mp_sum_scatter_cv, mp_sum_scatter_zv
302 : GENERIC, PUBLIC :: sum_scatter => &
303 : mp_sum_scatter_iv, mp_sum_scatter_lv, mp_sum_scatter_rv, &
304 : mp_sum_scatter_dv, mp_sum_scatter_cv, mp_sum_scatter_zv
305 :
306 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_prod_r, mp_prod_d, mp_prod_c, mp_prod_z
307 : GENERIC, PUBLIC :: prod => mp_prod_r, mp_prod_d, mp_prod_c, mp_prod_z
308 :
309 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_gather_i, mp_gather_iv, mp_gather_im, &
310 : mp_gather_l, mp_gather_lv, mp_gather_lm, &
311 : mp_gather_r, mp_gather_rv, mp_gather_rm, &
312 : mp_gather_d, mp_gather_dv, mp_gather_dm, &
313 : mp_gather_c, mp_gather_cv, mp_gather_cm, &
314 : mp_gather_z, mp_gather_zv, mp_gather_zm, &
315 : mp_gather_i_src, mp_gather_iv_src, mp_gather_im_src, &
316 : mp_gather_l_src, mp_gather_lv_src, mp_gather_lm_src, &
317 : mp_gather_r_src, mp_gather_rv_src, mp_gather_rm_src, &
318 : mp_gather_d_src, mp_gather_dv_src, mp_gather_dm_src, &
319 : mp_gather_c_src, mp_gather_cv_src, mp_gather_cm_src, &
320 : mp_gather_z_src, mp_gather_zv_src, mp_gather_zm_src
321 : GENERIC, PUBLIC :: gather => mp_gather_i, mp_gather_iv, mp_gather_im, &
322 : mp_gather_l, mp_gather_lv, mp_gather_lm, &
323 : mp_gather_r, mp_gather_rv, mp_gather_rm, &
324 : mp_gather_d, mp_gather_dv, mp_gather_dm, &
325 : mp_gather_c, mp_gather_cv, mp_gather_cm, &
326 : mp_gather_z, mp_gather_zv, mp_gather_zm, &
327 : mp_gather_i_src, mp_gather_iv_src, mp_gather_im_src, &
328 : mp_gather_l_src, mp_gather_lv_src, mp_gather_lm_src, &
329 : mp_gather_r_src, mp_gather_rv_src, mp_gather_rm_src, &
330 : mp_gather_d_src, mp_gather_dv_src, mp_gather_dm_src, &
331 : mp_gather_c_src, mp_gather_cv_src, mp_gather_cm_src, &
332 : mp_gather_z_src, mp_gather_zv_src, mp_gather_zm_src
333 :
334 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_gatherv_iv, &
335 : mp_gatherv_lv, mp_gatherv_rv, mp_gatherv_dv, &
336 : mp_gatherv_cv, mp_gatherv_zv, mp_gatherv_lm2, mp_gatherv_rm2, &
337 : mp_gatherv_dm2, mp_gatherv_cm2, mp_gatherv_zm2, mp_gatherv_iv_src, &
338 : mp_gatherv_lv_src, mp_gatherv_rv_src, mp_gatherv_dv_src, &
339 : mp_gatherv_cv_src, mp_gatherv_zv_src, mp_gatherv_lm2_src, mp_gatherv_rm2_src, &
340 : mp_gatherv_dm2_src, mp_gatherv_cm2_src, mp_gatherv_zm2_src
341 : GENERIC, PUBLIC :: gatherv => mp_gatherv_iv, &
342 : mp_gatherv_lv, mp_gatherv_rv, mp_gatherv_dv, &
343 : mp_gatherv_cv, mp_gatherv_zv, mp_gatherv_lm2, mp_gatherv_rm2, &
344 : mp_gatherv_dm2, mp_gatherv_cm2, mp_gatherv_zm2, mp_gatherv_iv_src, &
345 : mp_gatherv_lv_src, mp_gatherv_rv_src, mp_gatherv_dv_src, &
346 : mp_gatherv_cv_src, mp_gatherv_zv_src, mp_gatherv_lm2_src, mp_gatherv_rm2_src, &
347 : mp_gatherv_dm2_src, mp_gatherv_cm2_src, mp_gatherv_zm2_src
348 :
349 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_igatherv_iv, &
350 : mp_igatherv_lv, mp_igatherv_rv, mp_igatherv_dv, &
351 : mp_igatherv_cv, mp_igatherv_zv
352 : GENERIC, PUBLIC :: igatherv => mp_igatherv_iv, &
353 : mp_igatherv_lv, mp_igatherv_rv, mp_igatherv_dv, &
354 : mp_igatherv_cv, mp_igatherv_zv
355 :
356 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_allgather_i, mp_allgather_i2, &
357 : mp_allgather_i12, mp_allgather_i23, mp_allgather_i34, &
358 : mp_allgather_i22, mp_allgather_l, mp_allgather_l2, &
359 : mp_allgather_l12, mp_allgather_l23, mp_allgather_l34, &
360 : mp_allgather_l22, mp_allgather_r, mp_allgather_r2, &
361 : mp_allgather_r12, mp_allgather_r23, mp_allgather_r34, &
362 : mp_allgather_r22, mp_allgather_d, mp_allgather_d2, &
363 : mp_allgather_d12, mp_allgather_d23, mp_allgather_d34, &
364 : mp_allgather_d22, mp_allgather_c, mp_allgather_c2, &
365 : mp_allgather_c12, mp_allgather_c23, mp_allgather_c34, &
366 : mp_allgather_c22, mp_allgather_z, mp_allgather_z2, &
367 : mp_allgather_z12, mp_allgather_z23, mp_allgather_z34, &
368 : mp_allgather_z22
369 : GENERIC, PUBLIC :: allgather => mp_allgather_i, mp_allgather_i2, &
370 : mp_allgather_i12, mp_allgather_i23, mp_allgather_i34, &
371 : mp_allgather_i22, mp_allgather_l, mp_allgather_l2, &
372 : mp_allgather_l12, mp_allgather_l23, mp_allgather_l34, &
373 : mp_allgather_l22, mp_allgather_r, mp_allgather_r2, &
374 : mp_allgather_r12, mp_allgather_r23, mp_allgather_r34, &
375 : mp_allgather_r22, mp_allgather_d, mp_allgather_d2, &
376 : mp_allgather_d12, mp_allgather_d23, mp_allgather_d34, &
377 : mp_allgather_d22, mp_allgather_c, mp_allgather_c2, &
378 : mp_allgather_c12, mp_allgather_c23, mp_allgather_c34, &
379 : mp_allgather_c22, mp_allgather_z, mp_allgather_z2, &
380 : mp_allgather_z12, mp_allgather_z23, mp_allgather_z34, &
381 : mp_allgather_z22
382 :
383 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_allgatherv_iv, mp_allgatherv_lv, &
384 : mp_allgatherv_rv, mp_allgatherv_dv, mp_allgatherv_cv, mp_allgatherv_zv, &
385 : mp_allgatherv_im2, mp_allgatherv_lm2, mp_allgatherv_rm2, &
386 : mp_allgatherv_dm2, mp_allgatherv_cm2, mp_allgatherv_zm2
387 : GENERIC, PUBLIC :: allgatherv => mp_allgatherv_iv, mp_allgatherv_lv, &
388 : mp_allgatherv_rv, mp_allgatherv_dv, mp_allgatherv_cv, mp_allgatherv_zv, &
389 : mp_allgatherv_im2, mp_allgatherv_lm2, mp_allgatherv_rm2, &
390 : mp_allgatherv_dm2, mp_allgatherv_cm2, mp_allgatherv_zm2
391 :
392 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_iallgather_i, mp_iallgather_l, &
393 : mp_iallgather_r, mp_iallgather_d, mp_iallgather_c, mp_iallgather_z, &
394 : mp_iallgather_i11, mp_iallgather_l11, mp_iallgather_r11, mp_iallgather_d11, &
395 : mp_iallgather_c11, mp_iallgather_z11, mp_iallgather_i13, mp_iallgather_l13, &
396 : mp_iallgather_r13, mp_iallgather_d13, mp_iallgather_c13, mp_iallgather_z13, &
397 : mp_iallgather_i22, mp_iallgather_l22, mp_iallgather_r22, mp_iallgather_d22, &
398 : mp_iallgather_c22, mp_iallgather_z22, mp_iallgather_i24, mp_iallgather_l24, &
399 : mp_iallgather_r24, mp_iallgather_d24, mp_iallgather_c24, mp_iallgather_z24, &
400 : mp_iallgather_i33, mp_iallgather_l33, mp_iallgather_r33, mp_iallgather_d33, &
401 : mp_iallgather_c33, mp_iallgather_z33
402 : GENERIC, PUBLIC :: iallgather => mp_iallgather_i, mp_iallgather_l, &
403 : mp_iallgather_r, mp_iallgather_d, mp_iallgather_c, mp_iallgather_z, &
404 : mp_iallgather_i11, mp_iallgather_l11, mp_iallgather_r11, mp_iallgather_d11, &
405 : mp_iallgather_c11, mp_iallgather_z11, mp_iallgather_i13, mp_iallgather_l13, &
406 : mp_iallgather_r13, mp_iallgather_d13, mp_iallgather_c13, mp_iallgather_z13, &
407 : mp_iallgather_i22, mp_iallgather_l22, mp_iallgather_r22, mp_iallgather_d22, &
408 : mp_iallgather_c22, mp_iallgather_z22, mp_iallgather_i24, mp_iallgather_l24, &
409 : mp_iallgather_r24, mp_iallgather_d24, mp_iallgather_c24, mp_iallgather_z24, &
410 : mp_iallgather_i33, mp_iallgather_l33, mp_iallgather_r33, mp_iallgather_d33, &
411 : mp_iallgather_c33, mp_iallgather_z33
412 :
413 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_iallgatherv_iv, mp_iallgatherv_iv2, &
414 : mp_iallgatherv_lv, mp_iallgatherv_lv2, mp_iallgatherv_rv, mp_iallgatherv_rv2, &
415 : mp_iallgatherv_dv, mp_iallgatherv_dv2, mp_iallgatherv_cv, mp_iallgatherv_cv2, &
416 : mp_iallgatherv_zv, mp_iallgatherv_zv2
417 : GENERIC, PUBLIC :: iallgatherv => mp_iallgatherv_iv, mp_iallgatherv_iv2, &
418 : mp_iallgatherv_lv, mp_iallgatherv_lv2, mp_iallgatherv_rv, mp_iallgatherv_rv2, &
419 : mp_iallgatherv_dv, mp_iallgatherv_dv2, mp_iallgatherv_cv, mp_iallgatherv_cv2, &
420 : mp_iallgatherv_zv, mp_iallgatherv_zv2
421 :
422 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_scatter_iv, mp_scatter_lv, &
423 : mp_scatter_rv, mp_scatter_dv, mp_scatter_cv, mp_scatter_zv
424 : GENERIC, PUBLIC :: scatter => mp_scatter_iv, mp_scatter_lv, &
425 : mp_scatter_rv, mp_scatter_dv, mp_scatter_cv, mp_scatter_zv
426 :
427 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_iscatter_i, mp_iscatter_l, &
428 : mp_iscatter_r, mp_iscatter_d, mp_iscatter_c, mp_iscatter_z, &
429 : mp_iscatter_iv2, mp_iscatter_lv2, mp_iscatter_rv2, mp_iscatter_dv2, &
430 : mp_iscatter_cv2, mp_iscatter_zv2
431 : GENERIC, PUBLIC :: iscatter => mp_iscatter_i, mp_iscatter_l, &
432 : mp_iscatter_r, mp_iscatter_d, mp_iscatter_c, mp_iscatter_z, &
433 : mp_iscatter_iv2, mp_iscatter_lv2, mp_iscatter_rv2, mp_iscatter_dv2, &
434 : mp_iscatter_cv2, mp_iscatter_zv2
435 :
436 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_iscatterv_iv, mp_iscatterv_lv, &
437 : mp_iscatterv_rv, mp_iscatterv_dv, mp_iscatterv_cv, mp_iscatterv_zv
438 : GENERIC, PUBLIC :: iscatterv => mp_iscatterv_iv, mp_iscatterv_lv, &
439 : mp_iscatterv_rv, mp_iscatterv_dv, mp_iscatterv_cv, mp_iscatterv_zv
440 :
441 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_alltoall_i, mp_alltoall_i22, mp_alltoall_i33, &
442 : mp_alltoall_i44, mp_alltoall_i55, mp_alltoall_i45, mp_alltoall_i34, &
443 : mp_alltoall_i11v, mp_alltoall_i22v, mp_alltoall_i54, &
444 : mp_alltoall_l, mp_alltoall_l22, mp_alltoall_l33, &
445 : mp_alltoall_l44, mp_alltoall_l55, mp_alltoall_l45, mp_alltoall_l34, &
446 : mp_alltoall_l11v, mp_alltoall_l22v, mp_alltoall_l54, &
447 : mp_alltoall_r, mp_alltoall_r22, mp_alltoall_r33, &
448 : mp_alltoall_r44, mp_alltoall_r55, mp_alltoall_r45, mp_alltoall_r34, &
449 : mp_alltoall_r11v, mp_alltoall_r22v, mp_alltoall_r54, &
450 : mp_alltoall_d, mp_alltoall_d22, mp_alltoall_d33, &
451 : mp_alltoall_d44, mp_alltoall_d55, mp_alltoall_d45, mp_alltoall_d34, &
452 : mp_alltoall_d11v, mp_alltoall_d22v, mp_alltoall_d54, &
453 : mp_alltoall_c, mp_alltoall_c22, mp_alltoall_c33, &
454 : mp_alltoall_c44, mp_alltoall_c55, mp_alltoall_c45, mp_alltoall_c34, &
455 : mp_alltoall_c11v, mp_alltoall_c22v, mp_alltoall_c54, &
456 : mp_alltoall_z, mp_alltoall_z22, mp_alltoall_z33, &
457 : mp_alltoall_z44, mp_alltoall_z55, mp_alltoall_z45, mp_alltoall_z34, &
458 : mp_alltoall_z11v, mp_alltoall_z22v, mp_alltoall_z54
459 : GENERIC, PUBLIC :: alltoall => mp_alltoall_i, mp_alltoall_i22, mp_alltoall_i33, &
460 : mp_alltoall_i44, mp_alltoall_i55, mp_alltoall_i45, mp_alltoall_i34, &
461 : mp_alltoall_i11v, mp_alltoall_i22v, mp_alltoall_i54, &
462 : mp_alltoall_l, mp_alltoall_l22, mp_alltoall_l33, &
463 : mp_alltoall_l44, mp_alltoall_l55, mp_alltoall_l45, mp_alltoall_l34, &
464 : mp_alltoall_l11v, mp_alltoall_l22v, mp_alltoall_l54, &
465 : mp_alltoall_r, mp_alltoall_r22, mp_alltoall_r33, &
466 : mp_alltoall_r44, mp_alltoall_r55, mp_alltoall_r45, mp_alltoall_r34, &
467 : mp_alltoall_r11v, mp_alltoall_r22v, mp_alltoall_r54, &
468 : mp_alltoall_d, mp_alltoall_d22, mp_alltoall_d33, &
469 : mp_alltoall_d44, mp_alltoall_d55, mp_alltoall_d45, mp_alltoall_d34, &
470 : mp_alltoall_d11v, mp_alltoall_d22v, mp_alltoall_d54, &
471 : mp_alltoall_c, mp_alltoall_c22, mp_alltoall_c33, &
472 : mp_alltoall_c44, mp_alltoall_c55, mp_alltoall_c45, mp_alltoall_c34, &
473 : mp_alltoall_c11v, mp_alltoall_c22v, mp_alltoall_c54, &
474 : mp_alltoall_z, mp_alltoall_z22, mp_alltoall_z33, &
475 : mp_alltoall_z44, mp_alltoall_z55, mp_alltoall_z45, mp_alltoall_z34, &
476 : mp_alltoall_z11v, mp_alltoall_z22v, mp_alltoall_z54
477 :
478 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_send_i, mp_send_iv, mp_send_im2, mp_send_im3, &
479 : mp_send_l, mp_send_lv, mp_send_lm2, mp_send_lm3, &
480 : mp_send_r, mp_send_rv, mp_send_rm2, mp_send_rm3, &
481 : mp_send_d, mp_send_dv, mp_send_dm2, mp_send_dm3, &
482 : mp_send_c, mp_send_cv, mp_send_cm2, mp_send_cm3, &
483 : mp_send_z, mp_send_zv, mp_send_zm2, mp_send_zm3
484 : GENERIC, PUBLIC :: send => mp_send_i, mp_send_iv, mp_send_im2, mp_send_im3, &
485 : mp_send_l, mp_send_lv, mp_send_lm2, mp_send_lm3, &
486 : mp_send_r, mp_send_rv, mp_send_rm2, mp_send_rm3, &
487 : mp_send_d, mp_send_dv, mp_send_dm2, mp_send_dm3, &
488 : mp_send_c, mp_send_cv, mp_send_cm2, mp_send_cm3, &
489 : mp_send_z, mp_send_zv, mp_send_zm2, mp_send_zm3
490 :
491 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_recv_i, mp_recv_iv, mp_recv_im2, mp_recv_im3, &
492 : mp_recv_l, mp_recv_lv, mp_recv_lm2, mp_recv_lm3, &
493 : mp_recv_r, mp_recv_rv, mp_recv_rm2, mp_recv_rm3, &
494 : mp_recv_d, mp_recv_dv, mp_recv_dm2, mp_recv_dm3, &
495 : mp_recv_c, mp_recv_cv, mp_recv_cm2, mp_recv_cm3, &
496 : mp_recv_z, mp_recv_zv, mp_recv_zm2, mp_recv_zm3
497 : GENERIC, PUBLIC :: recv => mp_recv_i, mp_recv_iv, mp_recv_im2, mp_recv_im3, &
498 : mp_recv_l, mp_recv_lv, mp_recv_lm2, mp_recv_lm3, &
499 : mp_recv_r, mp_recv_rv, mp_recv_rm2, mp_recv_rm3, &
500 : mp_recv_d, mp_recv_dv, mp_recv_dm2, mp_recv_dm3, &
501 : mp_recv_c, mp_recv_cv, mp_recv_cm2, mp_recv_cm3, &
502 : mp_recv_z, mp_recv_zv, mp_recv_zm2, mp_recv_zm3
503 :
504 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_isendrecv_i, mp_isendrecv_iv, &
505 : mp_isendrecv_l, mp_isendrecv_lv, mp_isendrecv_r, mp_isendrecv_rv, &
506 : mp_isendrecv_d, mp_isendrecv_dv, mp_isendrecv_c, mp_isendrecv_cv, &
507 : mp_isendrecv_z, mp_isendrecv_zv
508 : GENERIC, PUBLIC :: isendrecv => mp_isendrecv_i, mp_isendrecv_iv, &
509 : mp_isendrecv_l, mp_isendrecv_lv, mp_isendrecv_r, mp_isendrecv_rv, &
510 : mp_isendrecv_d, mp_isendrecv_dv, mp_isendrecv_c, mp_isendrecv_cv, &
511 : mp_isendrecv_z, mp_isendrecv_zv
512 :
513 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_isend_iv, mp_isend_im2, mp_isend_im3, mp_isend_im4, &
514 : mp_isend_lv, mp_isend_lm2, mp_isend_lm3, mp_isend_lm4, &
515 : mp_isend_rv, mp_isend_rm2, mp_isend_rm3, mp_isend_rm4, &
516 : mp_isend_dv, mp_isend_dm2, mp_isend_dm3, mp_isend_dm4, &
517 : mp_isend_cv, mp_isend_cm2, mp_isend_cm3, mp_isend_cm4, &
518 : mp_isend_zv, mp_isend_zm2, mp_isend_zm3, mp_isend_zm4, &
519 : mp_isend_bv, mp_isend_bm3, mp_isend_custom
520 : GENERIC, PUBLIC :: isend => mp_isend_iv, mp_isend_im2, mp_isend_im3, mp_isend_im4, &
521 : mp_isend_lv, mp_isend_lm2, mp_isend_lm3, mp_isend_lm4, &
522 : mp_isend_rv, mp_isend_rm2, mp_isend_rm3, mp_isend_rm4, &
523 : mp_isend_dv, mp_isend_dm2, mp_isend_dm3, mp_isend_dm4, &
524 : mp_isend_cv, mp_isend_cm2, mp_isend_cm3, mp_isend_cm4, &
525 : mp_isend_zv, mp_isend_zm2, mp_isend_zm3, mp_isend_zm4, &
526 : mp_isend_bv, mp_isend_bm3, mp_isend_custom
527 :
528 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_irecv_iv, mp_irecv_im2, mp_irecv_im3, mp_irecv_im4, &
529 : mp_irecv_lv, mp_irecv_lm2, mp_irecv_lm3, mp_irecv_lm4, &
530 : mp_irecv_rv, mp_irecv_rm2, mp_irecv_rm3, mp_irecv_rm4, &
531 : mp_irecv_dv, mp_irecv_dm2, mp_irecv_dm3, mp_irecv_dm4, &
532 : mp_irecv_cv, mp_irecv_cm2, mp_irecv_cm3, mp_irecv_cm4, &
533 : mp_irecv_zv, mp_irecv_zm2, mp_irecv_zm3, mp_irecv_zm4, &
534 : mp_irecv_bv, mp_irecv_bm3, mp_irecv_custom
535 : GENERIC, PUBLIC :: irecv => mp_irecv_iv, mp_irecv_im2, mp_irecv_im3, mp_irecv_im4, &
536 : mp_irecv_lv, mp_irecv_lm2, mp_irecv_lm3, mp_irecv_lm4, &
537 : mp_irecv_rv, mp_irecv_rm2, mp_irecv_rm3, mp_irecv_rm4, &
538 : mp_irecv_dv, mp_irecv_dm2, mp_irecv_dm3, mp_irecv_dm4, &
539 : mp_irecv_cv, mp_irecv_cm2, mp_irecv_cm3, mp_irecv_cm4, &
540 : mp_irecv_zv, mp_irecv_zm2, mp_irecv_zm3, mp_irecv_zm4, &
541 : mp_irecv_bv, mp_irecv_bm3, mp_irecv_custom
542 :
543 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: probe => mp_probe
544 :
545 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: sync => mp_sync
546 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: isync => mp_isync
547 :
548 : PROCEDURE, PUBLIC, PASS(comm1), NON_OVERRIDABLE :: compare => mp_comm_compare
549 : PROCEDURE, PUBLIC, PASS(comm1), NON_OVERRIDABLE :: rank_compare => mp_rank_compare
550 :
551 : PROCEDURE, PUBLIC, PASS(comm2), NON_OVERRIDABLE :: from_dup => mp_comm_dup
552 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: mp_comm_free
553 : GENERIC, PUBLIC :: free => mp_comm_free
554 :
555 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: mp_comm_init
556 : GENERIC, PUBLIC :: init => mp_comm_init
557 :
558 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: get_size => mp_comm_size
559 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: get_rank => mp_comm_rank
560 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: get_ndims => mp_comm_get_ndims
561 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: is_source => mp_comm_is_source
562 :
563 : ! Creation routines
564 : PROCEDURE, PRIVATE, PASS(sub_comm), NON_OVERRIDABLE :: mp_comm_split, mp_comm_split_direct
565 : GENERIC, PUBLIC :: from_split => mp_comm_split, mp_comm_split_direct
566 : PROCEDURE, PUBLIC, PASS(mp_new_comm), NON_OVERRIDABLE :: from_reordering => mp_reordering
567 : PROCEDURE, PUBLIC, PASS(comm_new), NON_OVERRIDABLE :: mp_comm_assign
568 : GENERIC, PUBLIC :: ASSIGNMENT(=) => mp_comm_assign
569 :
570 : ! Other Getters
571 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_comm_get_tag_ub
572 : GENERIC, PUBLIC :: get_tag_ub => mp_comm_get_tag_ub
573 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_comm_get_host_rank
574 : GENERIC, PUBLIC :: get_host_rank => mp_comm_get_host_rank
575 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_comm_get_io_rank
576 : GENERIC, PUBLIC :: get_io_rank => mp_comm_get_io_rank
577 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: mp_comm_get_wtime_is_global
578 : GENERIC, PUBLIC :: get_wtime_is_global => mp_comm_get_wtime_is_global
579 : END TYPE
580 :
581 : TYPE mp_request_type
582 : PRIVATE
583 : MPI_REQUEST_TYPE :: handle = mp_request_null_handle
584 : CONTAINS
585 : PROCEDURE, PUBLIC, NON_OVERRIDABLE :: set_handle => mp_request_type_set_handle
586 : PROCEDURE, PUBLIC, NON_OVERRIDABLE :: get_handle => mp_request_type_get_handle
587 : PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_request_op_eq
588 : PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_request_op_neq
589 : GENERIC, PUBLIC :: OPERATOR(==) => mp_request_op_eq
590 : GENERIC, PUBLIC :: OPERATOR(/=) => mp_request_op_neq
591 :
592 : PROCEDURE, PUBLIC, PASS(request), NON_OVERRIDABLE :: test => mp_test_1
593 :
594 : PROCEDURE, PUBLIC, PASS(request), NON_OVERRIDABLE :: wait => mp_wait
595 : END TYPE
596 :
597 : TYPE mp_win_type
598 : PRIVATE
599 : MPI_WIN_TYPE :: handle = mp_win_null_handle
600 : CONTAINS
601 : PROCEDURE, PUBLIC, NON_OVERRIDABLE :: set_handle => mp_win_type_set_handle
602 : PROCEDURE, PUBLIC, NON_OVERRIDABLE :: get_handle => mp_win_type_get_handle
603 : PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_win_op_eq
604 : PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_win_op_neq
605 : GENERIC, PUBLIC :: OPERATOR(==) => mp_win_op_eq
606 : GENERIC, PUBLIC :: OPERATOR(/=) => mp_win_op_neq
607 :
608 : PROCEDURE, PRIVATE, PASS(win), NON_OVERRIDABLE :: mp_win_create_iv, mp_win_create_lv, &
609 : mp_win_create_rv, mp_win_create_dv, mp_win_create_cv, mp_win_create_zv
610 : GENERIC, PUBLIC :: create => mp_win_create_iv, mp_win_create_lv, &
611 : mp_win_create_rv, mp_win_create_dv, mp_win_create_cv, mp_win_create_zv
612 :
613 : PROCEDURE, PRIVATE, PASS(win), NON_OVERRIDABLE :: mp_rget_iv, mp_rget_lv, &
614 : mp_rget_rv, mp_rget_dv, mp_rget_cv, mp_rget_zv
615 : GENERIC, PUBLIC :: rget => mp_rget_iv, mp_rget_lv, &
616 : mp_rget_rv, mp_rget_dv, mp_rget_cv, mp_rget_zv
617 :
618 : PROCEDURE, PUBLIC, PASS(win), NON_OVERRIDABLE :: free => mp_win_free
619 : PROCEDURE, PUBLIC, PASS(win_new), NON_OVERRIDABLE :: mp_win_assign
620 : GENERIC, PUBLIC :: ASSIGNMENT(=) => mp_win_assign
621 :
622 : PROCEDURE, PUBLIC, PASS(win), NON_OVERRIDABLE :: lock_all => mp_win_lock_all
623 : PROCEDURE, PUBLIC, PASS(win), NON_OVERRIDABLE :: unlock_all => mp_win_unlock_all
624 : PROCEDURE, PUBLIC, PASS(win), NON_OVERRIDABLE :: flush_all => mp_win_flush_all
625 : END TYPE
626 :
627 : TYPE mp_file_type
628 : PRIVATE
629 : MPI_FILE_TYPE :: handle = mp_file_null_handle
630 : CONTAINS
631 : PROCEDURE, PUBLIC, NON_OVERRIDABLE :: set_handle => mp_file_type_set_handle
632 : PROCEDURE, PUBLIC, NON_OVERRIDABLE :: get_handle => mp_file_type_get_handle
633 : PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_file_op_eq
634 : PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_file_op_neq
635 : GENERIC, PUBLIC :: OPERATOR(==) => mp_file_op_eq
636 : GENERIC, PUBLIC :: OPERATOR(/=) => mp_file_op_neq
637 :
638 : PROCEDURE, PRIVATE, PASS(fh), NON_OVERRIDABLE :: mp_file_write_at_ch, mp_file_write_at_chv, &
639 : mp_file_write_at_i, mp_file_write_at_iv, mp_file_write_at_r, mp_file_write_at_rv, &
640 : mp_file_write_at_d, mp_file_write_at_dv, mp_file_write_at_c, mp_file_write_at_cv, &
641 : mp_file_write_at_z, mp_file_write_at_zv, mp_file_write_at_l, mp_file_write_at_lv
642 : GENERIC, PUBLIC :: write_at => mp_file_write_at_ch, mp_file_write_at_chv, &
643 : mp_file_write_at_i, mp_file_write_at_iv, mp_file_write_at_r, mp_file_write_at_rv, &
644 : mp_file_write_at_d, mp_file_write_at_dv, mp_file_write_at_c, mp_file_write_at_cv, &
645 : mp_file_write_at_z, mp_file_write_at_zv, mp_file_write_at_l, mp_file_write_at_lv
646 :
647 : PROCEDURE, PRIVATE, PASS(fh), NON_OVERRIDABLE :: mp_file_write_at_all_ch, mp_file_write_at_all_chv, &
648 : mp_file_write_at_all_i, mp_file_write_at_all_iv, mp_file_write_at_all_l, mp_file_write_at_all_lv, &
649 : mp_file_write_at_all_r, mp_file_write_at_all_rv, mp_file_write_at_all_d, mp_file_write_at_all_dv, &
650 : mp_file_write_at_all_c, mp_file_write_at_all_cv, mp_file_write_at_all_z, mp_file_write_at_all_zv
651 : GENERIC, PUBLIC :: write_at_all => mp_file_write_at_all_ch, mp_file_write_at_all_chv, &
652 : mp_file_write_at_all_i, mp_file_write_at_all_iv, mp_file_write_at_all_l, mp_file_write_at_all_lv, &
653 : mp_file_write_at_all_r, mp_file_write_at_all_rv, mp_file_write_at_all_d, mp_file_write_at_all_dv, &
654 : mp_file_write_at_all_c, mp_file_write_at_all_cv, mp_file_write_at_all_z, mp_file_write_at_all_zv
655 :
656 : PROCEDURE, PRIVATE, PASS(fh), NON_OVERRIDABLE :: mp_file_read_at_ch, mp_file_read_at_chv, &
657 : mp_file_read_at_i, mp_file_read_at_iv, mp_file_read_at_r, mp_file_read_at_rv, &
658 : mp_file_read_at_d, mp_file_read_at_dv, mp_file_read_at_c, mp_file_read_at_cv, &
659 : mp_file_read_at_z, mp_file_read_at_zv, mp_file_read_at_l, mp_file_read_at_lv
660 : GENERIC, PUBLIC :: read_at => mp_file_read_at_ch, mp_file_read_at_chv, &
661 : mp_file_read_at_i, mp_file_read_at_iv, mp_file_read_at_r, mp_file_read_at_rv, &
662 : mp_file_read_at_d, mp_file_read_at_dv, mp_file_read_at_c, mp_file_read_at_cv, &
663 : mp_file_read_at_z, mp_file_read_at_zv, mp_file_read_at_l, mp_file_read_at_lv
664 :
665 : PROCEDURE, PRIVATE, PASS(fh), NON_OVERRIDABLE :: mp_file_read_at_all_ch, mp_file_read_at_all_chv, &
666 : mp_file_read_at_all_i, mp_file_read_at_all_iv, mp_file_read_at_all_l, mp_file_read_at_all_lv, &
667 : mp_file_read_at_all_r, mp_file_read_at_all_rv, mp_file_read_at_all_d, mp_file_read_at_all_dv, &
668 : mp_file_read_at_all_c, mp_file_read_at_all_cv, mp_file_read_at_all_z, mp_file_read_at_all_zv
669 : GENERIC, PUBLIC :: read_at_all => mp_file_read_at_all_ch, mp_file_read_at_all_chv, &
670 : mp_file_read_at_all_i, mp_file_read_at_all_iv, mp_file_read_at_all_l, mp_file_read_at_all_lv, &
671 : mp_file_read_at_all_r, mp_file_read_at_all_rv, mp_file_read_at_all_d, mp_file_read_at_all_dv, &
672 : mp_file_read_at_all_c, mp_file_read_at_all_cv, mp_file_read_at_all_z, mp_file_read_at_all_zv
673 :
674 : PROCEDURE, PUBLIC, PASS(fh), NON_OVERRIDABLE :: open => mp_file_open
675 : PROCEDURE, PUBLIC, PASS(fh), NON_OVERRIDABLE :: close => mp_file_close
676 : PROCEDURE, PRIVATE, PASS(fh_new), NON_OVERRIDABLE :: mp_file_assign
677 : GENERIC, PUBLIC :: ASSIGNMENT(=) => mp_file_assign
678 :
679 : PROCEDURE, PUBLIC, PASS(fh), NON_OVERRIDABLE :: get_size => mp_file_get_size
680 : PROCEDURE, PUBLIC, PASS(fh), NON_OVERRIDABLE :: get_position => mp_file_get_position
681 :
682 : PROCEDURE, PUBLIC, PASS(fh), NON_OVERRIDABLE :: read_all => mp_file_read_all_chv
683 : PROCEDURE, PUBLIC, PASS(fh), NON_OVERRIDABLE :: write_all => mp_file_write_all_chv
684 : END TYPE
685 :
686 : TYPE mp_info_type
687 : PRIVATE
688 : MPI_INFO_TYPE :: handle = mp_info_null_handle
689 : CONTAINS
690 : PROCEDURE, NON_OVERRIDABLE :: set_handle => mp_info_type_set_handle
691 : PROCEDURE, NON_OVERRIDABLE :: get_handle => mp_info_type_get_handle
692 : PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_info_op_eq
693 : PROCEDURE, PRIVATE, NON_OVERRIDABLE :: mp_info_op_neq
694 : GENERIC, PUBLIC :: OPERATOR(==) => mp_info_op_eq
695 : GENERIC, PUBLIC :: OPERATOR(/=) => mp_info_op_neq
696 : END TYPE
697 :
698 : TYPE, EXTENDS(mp_comm_type) :: mp_cart_type
699 : INTEGER, DIMENSION(:), ALLOCATABLE, PUBLIC :: mepos_cart, num_pe_cart
700 : LOGICAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: periodic
701 : CONTAINS
702 : PROCEDURE, PUBLIC, PASS(comm_cart), NON_OVERRIDABLE :: create => mp_cart_create
703 : PROCEDURE, PUBLIC, PASS(sub_comm), NON_OVERRIDABLE :: from_sub => mp_cart_sub
704 :
705 : PROCEDURE, PRIVATE, PASS(comm), NON_OVERRIDABLE :: get_info_cart => mp_cart_get
706 :
707 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: coords => mp_cart_coords
708 : PROCEDURE, PUBLIC, PASS(comm), NON_OVERRIDABLE :: rank_cart => mp_cart_rank
709 : END TYPE
710 :
711 : ! **************************************************************************************************
712 : !> \brief stores all the informations relevant to an mpi environment
713 : !> \param owns_group if it owns the group (and thus should free it when
714 : !> this object is deallocated)
715 : !> \param ref_count the reference count, when it is zero this object gets
716 : !> deallocated
717 : !> \par History
718 : !> 08.2002 created [fawzi]
719 : !> \author Fawzi Mohamed
720 : ! **************************************************************************************************
721 : TYPE, EXTENDS(mp_comm_type) :: mp_para_env_type
722 : PRIVATE
723 : ! We set it to true to have less initialization steps in case we create a new communicator
724 : LOGICAL :: owns_group = .TRUE.
725 : INTEGER :: ref_count = -1
726 : CONTAINS
727 : PROCEDURE, PUBLIC, PASS(para_env), NON_OVERRIDABLE :: retain => mp_para_env_retain
728 : PROCEDURE, PUBLIC, PASS(para_env), NON_OVERRIDABLE :: is_valid => mp_para_env_is_valid
729 : END TYPE mp_para_env_type
730 :
731 : ! **************************************************************************************************
732 : !> \brief represent a pointer to a para env (to build arrays)
733 : !> \param para_env the pointer to the para_env
734 : !> \par History
735 : !> 07.2003 created [fawzi]
736 : !> \author Fawzi Mohamed
737 : ! **************************************************************************************************
738 : TYPE mp_para_env_p_type
739 : TYPE(mp_para_env_type), POINTER :: para_env => NULL()
740 : END TYPE mp_para_env_p_type
741 :
742 : ! **************************************************************************************************
743 : !> \brief represent a multidimensional parallel environment
744 : !> \param mepos_cart the position of the actual processor
745 : !> \param num_pe_cart number of processors in the group in each dimension
746 : !> \param source_cart id of a special processor (for example the one for i-o,
747 : !> or the master
748 : !> \param owns_group if it owns the group (and thus should free it when
749 : !> this object is deallocated)
750 : !> \param ref_count the reference count, when it is zero this object gets
751 : !> deallocated
752 : !> \note
753 : !> not yet implemented for mpi
754 : !> \par History
755 : !> 08.2002 created [fawzi]
756 : !> \author Fawzi Mohamed
757 : ! **************************************************************************************************
758 : TYPE, EXTENDS(mp_cart_type) :: mp_para_cart_type
759 : PRIVATE
760 : ! We set it to true to have less initialization steps in case we create a new communicator
761 : LOGICAL :: owns_group = .TRUE.
762 : INTEGER :: ref_count = -1
763 : CONTAINS
764 : PROCEDURE, PUBLIC, PASS(cart), NON_OVERRIDABLE :: retain => mp_para_cart_retain
765 : PROCEDURE, PUBLIC, PASS(cart), NON_OVERRIDABLE :: is_valid => mp_para_cart_is_valid
766 : END TYPE mp_para_cart_type
767 :
768 : ! Create the constants from the corresponding handles
769 : TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_null = mp_comm_type(mp_comm_null_handle)
770 : TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_self = mp_comm_type(mp_comm_self_handle)
771 : TYPE(mp_comm_type), PARAMETER, PUBLIC :: mp_comm_world = mp_comm_type(mp_comm_world_handle)
772 : TYPE(mp_request_type), PARAMETER, PUBLIC :: mp_request_null = mp_request_type(mp_request_null_handle)
773 : TYPE(mp_win_type), PARAMETER, PUBLIC :: mp_win_null = mp_win_type(mp_win_null_handle)
774 : TYPE(mp_file_type), PARAMETER, PUBLIC :: mp_file_null = mp_file_type(mp_file_null_handle)
775 : TYPE(mp_info_type), PARAMETER, PUBLIC :: mp_info_null = mp_info_type(mp_info_null_handle)
776 :
777 : #if !defined(__parallel)
778 : ! This communicator is to be used in serial mode to emulate a valid communicator which is not a compiler constant
779 : INTEGER, PARAMETER, PRIVATE :: mp_comm_default_handle = 1
780 : TYPE(mp_comm_type), PARAMETER, PRIVATE :: mp_comm_default = mp_comm_type(mp_comm_default_handle)
781 : #endif
782 :
783 : ! Constants to compare communicators
784 : INTEGER, PARAMETER, PUBLIC :: mp_comm_ident = 0
785 : INTEGER, PARAMETER, PUBLIC :: mp_comm_congruent = 1
786 : INTEGER, PARAMETER, PUBLIC :: mp_comm_similar = 2
787 : INTEGER, PARAMETER, PUBLIC :: mp_comm_unequal = 3
788 : INTEGER, PARAMETER, PUBLIC :: mp_comm_compare_default = -1
789 :
790 : ! init and error
791 : PUBLIC :: mp_world_init, mp_world_finalize
792 : PUBLIC :: mp_abort
793 :
794 : ! informational / generation of sub comms
795 : PUBLIC :: mp_dims_create
796 : PUBLIC :: cp2k_is_parallel
797 :
798 : ! message passing
799 : PUBLIC :: mp_waitall, mp_waitany
800 : PUBLIC :: mp_testall, mp_testany
801 :
802 : ! Memory management
803 : PUBLIC :: mp_allocate, mp_deallocate
804 :
805 : ! I/O
806 : PUBLIC :: mp_file_delete
807 : PUBLIC :: mp_file_get_amode
808 :
809 : ! some 'advanced types' currently only used for dbcsr
810 : PUBLIC :: mp_type_descriptor_type
811 : PUBLIC :: mp_type_make
812 : PUBLIC :: mp_type_size
813 :
814 : ! vector types
815 : PUBLIC :: mp_type_indexed_make_r, mp_type_indexed_make_d, &
816 : mp_type_indexed_make_c, mp_type_indexed_make_z
817 :
818 : ! More I/O types and routines: variable spaced data using bytes for spacings
819 : PUBLIC :: mp_file_descriptor_type
820 : PUBLIC :: mp_file_type_free
821 : PUBLIC :: mp_file_type_hindexed_make_chv
822 : PUBLIC :: mp_file_type_set_view_chv
823 :
824 : PUBLIC :: mp_get_library_version
825 :
826 : ! assumed to be private
827 :
828 : INTERFACE mp_waitall
829 : MODULE PROCEDURE mp_waitall_1, mp_waitall_2
830 : END INTERFACE
831 :
832 : INTERFACE mp_testall
833 : MODULE PROCEDURE mp_testall_tv
834 : END INTERFACE
835 :
836 : INTERFACE mp_testany
837 : MODULE PROCEDURE mp_testany_1, mp_testany_2
838 : END INTERFACE
839 :
840 : INTERFACE mp_type_free
841 : MODULE PROCEDURE mp_type_free_m, mp_type_free_v
842 : END INTERFACE
843 :
844 : !
845 : ! interfaces to deal easily with scalars / vectors / matrices / ...
846 : ! of the different types (integers, doubles, logicals, characters)
847 : !
848 : INTERFACE mp_allocate
849 : MODULE PROCEDURE mp_allocate_i, &
850 : mp_allocate_l, &
851 : mp_allocate_r, &
852 : mp_allocate_d, &
853 : mp_allocate_c, &
854 : mp_allocate_z
855 : END INTERFACE
856 :
857 : INTERFACE mp_deallocate
858 : MODULE PROCEDURE mp_deallocate_i, &
859 : mp_deallocate_l, &
860 : mp_deallocate_r, &
861 : mp_deallocate_d, &
862 : mp_deallocate_c, &
863 : mp_deallocate_z
864 : END INTERFACE
865 :
866 : INTERFACE mp_type_make
867 : MODULE PROCEDURE mp_type_make_struct
868 : MODULE PROCEDURE mp_type_make_i, mp_type_make_l, &
869 : mp_type_make_r, mp_type_make_d, &
870 : mp_type_make_c, mp_type_make_z
871 : END INTERFACE
872 :
873 : INTERFACE mp_alloc_mem
874 : MODULE PROCEDURE mp_alloc_mem_i, mp_alloc_mem_l, &
875 : mp_alloc_mem_d, mp_alloc_mem_z, &
876 : mp_alloc_mem_r, mp_alloc_mem_c
877 : END INTERFACE
878 :
879 : INTERFACE mp_free_mem
880 : MODULE PROCEDURE mp_free_mem_i, mp_free_mem_l, &
881 : mp_free_mem_d, mp_free_mem_z, &
882 : mp_free_mem_r, mp_free_mem_c
883 : END INTERFACE
884 :
885 : ! Type declarations
886 : TYPE mp_indexing_meta_type
887 : INTEGER, DIMENSION(:), POINTER :: index => NULL(), chunks => NULL()
888 : END TYPE mp_indexing_meta_type
889 :
890 : TYPE mp_type_descriptor_type
891 : MPI_DATA_TYPE :: type_handle = mp_datatype_null_handle
892 : INTEGER :: length = -1
893 : #if defined(__parallel)
894 : INTEGER(kind=mpi_address_kind) :: base = -1
895 : #endif
896 : INTEGER(kind=int_4), DIMENSION(:), POINTER :: data_i => NULL()
897 : INTEGER(kind=int_8), DIMENSION(:), POINTER :: data_l => NULL()
898 : REAL(kind=real_4), DIMENSION(:), POINTER :: data_r => NULL()
899 : REAL(kind=real_8), DIMENSION(:), POINTER :: data_d => NULL()
900 : COMPLEX(kind=real_4), DIMENSION(:), POINTER :: data_c => NULL()
901 : COMPLEX(kind=real_8), DIMENSION(:), POINTER :: data_z => NULL()
902 : TYPE(mp_type_descriptor_type), DIMENSION(:), POINTER :: subtype => NULL()
903 : INTEGER :: vector_descriptor(2) = -1
904 : LOGICAL :: has_indexing = .FALSE.
905 : TYPE(mp_indexing_meta_type) :: index_descriptor = mp_indexing_meta_type()
906 : END TYPE mp_type_descriptor_type
907 :
908 : TYPE mp_file_indexing_meta_type
909 : INTEGER, DIMENSION(:), POINTER :: index => NULL()
910 : INTEGER(kind=file_offset), &
911 : DIMENSION(:), POINTER :: chunks => NULL()
912 : END TYPE mp_file_indexing_meta_type
913 :
914 : TYPE mp_file_descriptor_type
915 : MPI_DATA_TYPE :: type_handle = mp_datatype_null_handle
916 : INTEGER :: length = -1
917 : LOGICAL :: has_indexing = .FALSE.
918 : TYPE(mp_file_indexing_meta_type) :: index_descriptor = mp_file_indexing_meta_type()
919 : END TYPE
920 :
921 : ! we make some assumptions on the length of INTEGERS, REALS and LOGICALS
922 : INTEGER, PARAMETER :: intlen = BIT_SIZE(0)/8
923 : INTEGER, PARAMETER :: reallen = 8
924 : INTEGER, PARAMETER :: loglen = BIT_SIZE(0)/8
925 : INTEGER, PARAMETER :: charlen = 1
926 :
927 : LOGICAL, PUBLIC, SAVE :: mp_collect_timings = .FALSE.
928 :
929 : CONTAINS
930 :
931 : #:mute
932 : #:set types = ["comm", "request", "win", "file", "info"]
933 : #:endmute
934 : #:for type in types
935 2792100 : LOGICAL FUNCTION mp_${type}$_op_eq(${type}$1, ${type}$2)
936 : CLASS(mp_${type}$_type), INTENT(IN) :: ${type}$1, ${type}$2
937 : #if defined(__parallel) && defined(__MPI_F08)
938 2792100 : mp_${type}$_op_eq = (${type}$1%handle%mpi_val == ${type}$2%handle%mpi_val)
939 : #else
940 : mp_${type}$_op_eq = (${type}$1%handle == ${type}$2%handle)
941 : #endif
942 2792100 : END FUNCTION mp_${type}$_op_eq
943 :
944 2996232 : LOGICAL FUNCTION mp_${type}$_op_neq(${type}$1, ${type}$2)
945 : CLASS(mp_${type}$_type), INTENT(IN) :: ${type}$1, ${type}$2
946 : #if defined(__parallel) && defined(__MPI_F08)
947 2996232 : mp_${type}$_op_neq = (${type}$1%handle%mpi_val /= ${type}$2%handle%mpi_val)
948 : #else
949 : mp_${type}$_op_neq = (${type}$1%handle /= ${type}$2%handle)
950 : #endif
951 2996232 : END FUNCTION mp_${type}$_op_neq
952 :
953 5449515 : ELEMENTAL #{if type=="comm"}#IMPURE #{endif}#SUBROUTINE mp_${type}$_type_set_handle(this, handle #{if type=="comm"}#, ndims#{endif}#)
954 : CLASS(mp_${type}$_type), INTENT(INOUT) :: this
955 : INTEGER, INTENT(IN) :: handle
956 : #:if type=="comm"
957 : INTEGER, INTENT(IN), OPTIONAL :: ndims
958 : #:endif
959 :
960 : #if defined(__parallel) && defined(__MPI_F08)
961 5449515 : this%handle%mpi_val = handle
962 : #else
963 : this%handle = handle
964 : #endif
965 :
966 : #:if type=="comm"
967 : SELECT TYPE (this)
968 : CLASS IS (mp_cart_type)
969 0 : IF (.NOT. PRESENT(ndims)) &
970 : CALL cp_abort(__LOCATION__, &
971 0 : "Setup of a cartesian communicator requires information on the number of dimensions!")
972 : END SELECT
973 5445815 : IF (PRESENT(ndims)) this%ndims = ndims
974 5445815 : CALL this%init()
975 : #:endif
976 :
977 5449515 : END SUBROUTINE mp_${type}$_type_set_handle
978 :
979 2217326 : ELEMENTAL FUNCTION mp_${type}$_type_get_handle(this) RESULT(handle)
980 : CLASS(mp_${type}$_type), INTENT(IN) :: this
981 : INTEGER :: handle
982 :
983 : #if defined(__parallel) && defined(__MPI_F08)
984 2217326 : handle = this%handle%mpi_val
985 : #else
986 : handle = this%handle
987 : #endif
988 2217326 : END FUNCTION mp_${type}$_type_get_handle
989 : #:endfor
990 :
991 24304 : FUNCTION mp_comm_get_tag_ub(comm) RESULT(tag_ub)
992 : CLASS(mp_comm_type), INTENT(IN) :: comm
993 : INTEGER :: tag_ub
994 :
995 : #if defined(__parallel)
996 : INTEGER :: ierr
997 : LOGICAL :: flag
998 : INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
999 :
1000 24304 : CALL MPI_COMM_GET_ATTR(comm%handle, MPI_TAG_UB, attrval, flag, ierr)
1001 24304 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_tag_ub")
1002 24304 : IF (.NOT. flag) CPABORT("Upper bound of tags not available!")
1003 24304 : tag_ub = INT(attrval, KIND=KIND(tag_ub))
1004 : #else
1005 : MARK_USED(comm)
1006 : tag_ub = HUGE(1)
1007 : #endif
1008 24304 : END FUNCTION mp_comm_get_tag_ub
1009 :
1010 0 : FUNCTION mp_comm_get_host_rank(comm) RESULT(host_rank)
1011 : CLASS(mp_comm_type), INTENT(IN) :: comm
1012 : INTEGER :: host_rank
1013 :
1014 : #if defined(__parallel)
1015 : INTEGER :: ierr
1016 : LOGICAL :: flag
1017 : INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1018 :
1019 0 : CALL MPI_COMM_GET_ATTR(comm%handle, MPI_HOST, attrval, flag, ierr)
1020 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_host_rank")
1021 0 : IF (.NOT. flag) CPABORT("Host process rank not available!")
1022 0 : host_rank = INT(attrval, KIND=KIND(host_rank))
1023 : #else
1024 : MARK_USED(comm)
1025 : host_rank = 0
1026 : #endif
1027 0 : END FUNCTION mp_comm_get_host_rank
1028 :
1029 0 : FUNCTION mp_comm_get_io_rank(comm) RESULT(io_rank)
1030 : CLASS(mp_comm_type), INTENT(IN) :: comm
1031 : INTEGER :: io_rank
1032 :
1033 : #if defined(__parallel)
1034 : INTEGER :: ierr
1035 : LOGICAL :: flag
1036 : INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1037 :
1038 0 : CALL MPI_COMM_GET_ATTR(comm%handle, MPI_IO, attrval, flag, ierr)
1039 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_io_rank")
1040 0 : IF (.NOT. flag) CPABORT("IO rank not available!")
1041 0 : io_rank = INT(attrval, KIND=KIND(io_rank))
1042 : #else
1043 : MARK_USED(comm)
1044 : io_rank = 0
1045 : #endif
1046 0 : END FUNCTION mp_comm_get_io_rank
1047 :
1048 0 : FUNCTION mp_comm_get_wtime_is_global(comm) RESULT(wtime_is_global)
1049 : CLASS(mp_comm_type), INTENT(IN) :: comm
1050 : LOGICAL :: wtime_is_global
1051 :
1052 : #if defined(__parallel)
1053 : INTEGER :: ierr
1054 : LOGICAL :: flag
1055 : INTEGER(KIND=MPI_ADDRESS_KIND) :: attrval
1056 :
1057 0 : CALL MPI_COMM_GET_ATTR(comm%handle, MPI_TAG_UB, attrval, flag, ierr)
1058 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_get_attr @ mp_comm_get_wtime_is_global")
1059 0 : IF (.NOT. flag) CPABORT("Synchronization state of WTIME not available!")
1060 0 : wtime_is_global = (attrval == 1_MPI_ADDRESS_KIND)
1061 : #else
1062 : MARK_USED(comm)
1063 : wtime_is_global = .TRUE.
1064 : #endif
1065 0 : END FUNCTION mp_comm_get_wtime_is_global
1066 :
1067 : ! **************************************************************************************************
1068 : !> \brief initializes the system default communicator
1069 : !> \param mp_comm [output] : handle of the default communicator
1070 : !> \par History
1071 : !> 2.2004 created [Joost VandeVondele ]
1072 : !> \note
1073 : !> should only be called once
1074 : ! **************************************************************************************************
1075 9290 : SUBROUTINE mp_world_init(mp_comm)
1076 : CLASS(mp_comm_type), INTENT(OUT) :: mp_comm
1077 : #if defined(__parallel)
1078 : INTEGER :: ierr
1079 : !$ INTEGER :: provided_tsl
1080 : !$ LOGICAL :: no_threading_support
1081 :
1082 : #if defined(__NO_MPI_THREAD_SUPPORT_CHECK)
1083 : ! Hack that does not request or check MPI thread support level.
1084 : ! User asserts that the MPI library will work correctly with
1085 : ! threads.
1086 : !
1087 : !$ no_threading_support = .TRUE.
1088 : #else
1089 : ! Does the right thing when using OpenMP: requests that the MPI
1090 : ! library supports serialized mode and verifies that the MPI library
1091 : ! provides that support.
1092 : !
1093 : ! Developers: Only the master thread will ever make calls to the
1094 : ! MPI library.
1095 : !
1096 9290 : !$ no_threading_support = .FALSE.
1097 : #endif
1098 : !$ IF (no_threading_support) THEN
1099 : CALL mpi_init(ierr)
1100 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init @ mp_world_init")
1101 : !$ ELSE
1102 9290 : !$OMP MASTER
1103 : #if defined(__DLAF)
1104 : ! DLA-Future requires that the MPI library supports
1105 : ! THREAD_MULTIPLE mode
1106 : !$ CALL mpi_init_thread(MPI_THREAD_MULTIPLE, provided_tsl, ierr)
1107 : #else
1108 9290 : !$ CALL mpi_init_thread(MPI_THREAD_SERIALIZED, provided_tsl, ierr)
1109 : #endif
1110 9290 : !$ IF (ierr /= 0) CALL mp_stop(ierr, "mpi_init_thread @ mp_world_init")
1111 : #if defined(__DLAF)
1112 : !$ IF (provided_tsl < MPI_THREAD_MULTIPLE) THEN
1113 : !$ CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_MULTIPLE), required by DLA-Future. Build CP2K without DLA-Future.")
1114 : !$ END IF
1115 : #else
1116 9290 : !$ IF (provided_tsl < MPI_THREAD_SERIALIZED) THEN
1117 0 : !$ CALL mp_stop(0, "MPI library does not support the requested level of threading (MPI_THREAD_SERIALIZED).")
1118 : !$ END IF
1119 : #endif
1120 : !$OMP END MASTER
1121 : !$ END IF
1122 9290 : CALL mpi_comm_set_errhandler(MPI_COMM_WORLD, MPI_ERRORS_RETURN, ierr)
1123 9290 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_set_errhandler @ mp_world_init")
1124 : #endif
1125 9290 : debug_comm_count = 1
1126 9290 : mp_comm = mp_comm_world
1127 9290 : CALL mp_comm%init()
1128 9290 : CALL add_mp_perf_env()
1129 9290 : END SUBROUTINE mp_world_init
1130 :
1131 : ! **************************************************************************************************
1132 : !> \brief re-create the system default communicator with a different MPI
1133 : !> rank order
1134 : !> \param mp_comm [output] : handle of the default communicator
1135 : !> \param mp_new_comm ...
1136 : !> \param ranks_order ...
1137 : !> \par History
1138 : !> 1.2012 created [ Christiane Pousa ]
1139 : !> \note
1140 : !> should only be called once, at very beginning of CP2K run
1141 : ! **************************************************************************************************
1142 744 : SUBROUTINE mp_reordering(mp_comm, mp_new_comm, ranks_order)
1143 : CLASS(mp_comm_type), INTENT(IN) :: mp_comm
1144 : CLASS(mp_comm_type), INTENT(out) :: mp_new_comm
1145 : INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: ranks_order
1146 :
1147 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_reordering'
1148 :
1149 : INTEGER :: handle, ierr
1150 : #if defined(__parallel)
1151 : MPI_GROUP_TYPE :: newgroup, oldgroup
1152 : #endif
1153 :
1154 744 : CALL mp_timeset(routineN, handle)
1155 : ierr = 0
1156 : #if defined(__parallel)
1157 :
1158 744 : CALL mpi_comm_group(mp_comm%handle, oldgroup, ierr)
1159 744 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_reordering")
1160 744 : CALL mpi_group_incl(oldgroup, SIZE(ranks_order), ranks_order, newgroup, ierr)
1161 744 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_incl @ mp_reordering")
1162 :
1163 744 : CALL mpi_comm_create(mp_comm%handle, newgroup, mp_new_comm%handle, ierr)
1164 744 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_create @ mp_reordering")
1165 :
1166 744 : CALL mpi_group_free(oldgroup, ierr)
1167 744 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1168 744 : CALL mpi_group_free(newgroup, ierr)
1169 744 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_group_free @ mp_reordering")
1170 :
1171 744 : CALL add_perf(perf_id=1, count=1)
1172 : #else
1173 : MARK_USED(mp_comm)
1174 : MARK_USED(ranks_order)
1175 : mp_new_comm%handle = mp_comm_default_handle
1176 : #endif
1177 744 : debug_comm_count = debug_comm_count + 1
1178 744 : CALL mp_new_comm%init()
1179 744 : CALL mp_timestop(handle)
1180 744 : END SUBROUTINE mp_reordering
1181 :
1182 : ! **************************************************************************************************
1183 : !> \brief finalizes the system default communicator
1184 : !> \par History
1185 : !> 2.2004 created [Joost VandeVondele]
1186 : ! **************************************************************************************************
1187 18580 : SUBROUTINE mp_world_finalize()
1188 :
1189 : CHARACTER(LEN=default_string_length) :: debug_comm_count_char
1190 : #if defined(__parallel)
1191 : INTEGER :: ierr
1192 9290 : CALL mpi_barrier(MPI_COMM_WORLD, ierr) ! call mpi directly to avoid 0 stack pointer
1193 : #endif
1194 9290 : CALL rm_mp_perf_env()
1195 :
1196 9290 : debug_comm_count = debug_comm_count - 1
1197 : #if defined(__parallel)
1198 9290 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_world_finalize")
1199 : #endif
1200 9290 : IF (debug_comm_count /= 0) THEN
1201 : ! A bug, we're leaking or double-freeing communicators. Needs to be fixed where the leak happens.
1202 : ! Memory leak checking might be helpful to locate the culprit
1203 0 : WRITE (unit=debug_comm_count_char, FMT='(I2)') debug_comm_count
1204 : CALL cp_abort(__LOCATION__, "mp_world_finalize: assert failed:"// &
1205 0 : " leaking communicators "//ADJUSTL(TRIM(debug_comm_count_char)))
1206 : END IF
1207 : #if defined(__parallel)
1208 9290 : CALL mpi_finalize(ierr)
1209 9290 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_finalize @ mp_world_finalize")
1210 : #endif
1211 :
1212 9290 : END SUBROUTINE mp_world_finalize
1213 :
1214 : ! all the following routines should work for a given communicator, not MPI_WORLD
1215 :
1216 : ! **************************************************************************************************
1217 : !> \brief globally stops all tasks
1218 : !> this is intended to be low level, most of CP2K should call cp_abort()
1219 : ! **************************************************************************************************
1220 0 : SUBROUTINE mp_abort()
1221 : INTEGER :: ierr
1222 :
1223 0 : ierr = 0
1224 :
1225 : #if !defined(__NO_ABORT)
1226 : #if defined(__parallel)
1227 : CALL mpi_abort(MPI_COMM_WORLD, 1, ierr)
1228 : #else
1229 : CALL m_abort()
1230 : #endif
1231 : #endif
1232 : ! this routine never returns and levels with non-zero exit code
1233 0 : STOP 1
1234 : END SUBROUTINE mp_abort
1235 :
1236 : ! **************************************************************************************************
1237 : !> \brief stops *after an mpi error* translating the error code
1238 : !> \param ierr an error code * returned by an mpi call *
1239 : !> \param prg_code ...
1240 : !> \note
1241 : !> this function is private to message_passing.F
1242 : ! **************************************************************************************************
1243 0 : SUBROUTINE mp_stop(ierr, prg_code)
1244 : INTEGER, INTENT(IN) :: ierr
1245 : CHARACTER(LEN=*), INTENT(IN) :: prg_code
1246 :
1247 : #if defined(__parallel)
1248 : INTEGER :: istat, len
1249 : CHARACTER(LEN=MPI_MAX_ERROR_STRING) :: error_string
1250 : CHARACTER(LEN=MPI_MAX_ERROR_STRING + 512) :: full_error
1251 : #else
1252 : CHARACTER(LEN=512) :: full_error
1253 : #endif
1254 :
1255 : #if defined(__parallel)
1256 0 : CALL mpi_error_string(ierr, error_string, len, istat)
1257 0 : WRITE (full_error, '(A,I0,A)') ' MPI error ', ierr, ' in '//TRIM(prg_code)//' : '//error_string(1:len)
1258 : #else
1259 : WRITE (full_error, '(A,I0,A)') ' MPI error (!?) ', ierr, ' in '//TRIM(prg_code)
1260 : #endif
1261 :
1262 0 : CPABORT(full_error)
1263 :
1264 0 : END SUBROUTINE mp_stop
1265 :
1266 : ! **************************************************************************************************
1267 : !> \brief synchronizes with a barrier a given group of mpi tasks
1268 : !> \param group mpi communicator
1269 : ! **************************************************************************************************
1270 6631592 : SUBROUTINE mp_sync(comm)
1271 : CLASS(mp_comm_type), INTENT(IN) :: comm
1272 :
1273 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sync'
1274 :
1275 : INTEGER :: handle, ierr
1276 :
1277 : ierr = 0
1278 3315796 : CALL mp_timeset(routineN, handle)
1279 :
1280 : #if defined(__parallel)
1281 3315796 : CALL mpi_barrier(comm%handle, ierr)
1282 3315796 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_barrier @ mp_sync")
1283 3315796 : CALL add_perf(perf_id=5, count=1)
1284 : #else
1285 : MARK_USED(comm)
1286 : #endif
1287 3315796 : CALL mp_timestop(handle)
1288 :
1289 3315796 : END SUBROUTINE mp_sync
1290 :
1291 : ! **************************************************************************************************
1292 : !> \brief synchronizes with a barrier a given group of mpi tasks
1293 : !> \param comm mpi communicator
1294 : !> \param request ...
1295 : ! **************************************************************************************************
1296 0 : SUBROUTINE mp_isync(comm, request)
1297 : CLASS(mp_comm_type), INTENT(IN) :: comm
1298 : TYPE(mp_request_type), INTENT(OUT) :: request
1299 :
1300 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isync'
1301 :
1302 : INTEGER :: handle, ierr
1303 :
1304 : ierr = 0
1305 0 : CALL mp_timeset(routineN, handle)
1306 :
1307 : #if defined(__parallel)
1308 0 : CALL mpi_ibarrier(comm%handle, request%handle, ierr)
1309 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ibarrier @ mp_isync")
1310 0 : CALL add_perf(perf_id=26, count=1)
1311 : #else
1312 : MARK_USED(comm)
1313 : request = mp_request_null
1314 : #endif
1315 0 : CALL mp_timestop(handle)
1316 :
1317 0 : END SUBROUTINE mp_isync
1318 :
1319 : ! **************************************************************************************************
1320 : !> \brief returns task id for a given mpi communicator
1321 : !> \param taskid The ID of the communicator
1322 : !> \param comm mpi communicator
1323 : ! **************************************************************************************************
1324 34702040 : SUBROUTINE mp_comm_rank(taskid, comm)
1325 :
1326 : INTEGER, INTENT(OUT) :: taskid
1327 : CLASS(mp_comm_type), INTENT(IN) :: comm
1328 :
1329 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_rank'
1330 :
1331 : INTEGER :: handle
1332 : #if defined(__parallel)
1333 : INTEGER :: ierr
1334 : #endif
1335 :
1336 17351020 : CALL mp_timeset(routineN, handle)
1337 :
1338 : #if defined(__parallel)
1339 17351020 : CALL mpi_comm_rank(comm%handle, taskid, ierr)
1340 17351020 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_rank")
1341 : #else
1342 : MARK_USED(comm)
1343 : taskid = 0
1344 : #endif
1345 17351020 : CALL mp_timestop(handle)
1346 :
1347 17351020 : END SUBROUTINE mp_comm_rank
1348 :
1349 : ! **************************************************************************************************
1350 : !> \brief returns number of tasks for a given mpi communicator
1351 : !> \param numtask ...
1352 : !> \param comm mpi communicator
1353 : ! **************************************************************************************************
1354 34702040 : SUBROUTINE mp_comm_size(numtask, comm)
1355 :
1356 : INTEGER, INTENT(OUT) :: numtask
1357 : CLASS(mp_comm_type), INTENT(IN) :: comm
1358 :
1359 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_size'
1360 :
1361 : INTEGER :: handle
1362 : #if defined(__parallel)
1363 : INTEGER :: ierr
1364 : #endif
1365 :
1366 17351020 : CALL mp_timeset(routineN, handle)
1367 :
1368 : #if defined(__parallel)
1369 17351020 : CALL mpi_comm_size(comm%handle, numtask, ierr)
1370 17351020 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_rank @ mp_comm_size")
1371 : #else
1372 : MARK_USED(comm)
1373 : numtask = 1
1374 : #endif
1375 17351020 : CALL mp_timestop(handle)
1376 :
1377 17351020 : END SUBROUTINE mp_comm_size
1378 :
1379 : ! **************************************************************************************************
1380 : !> \brief returns info for a given Cartesian MPI communicator
1381 : !> \param comm ...
1382 : !> \param ndims ...
1383 : !> \param dims ...
1384 : !> \param task_coor ...
1385 : !> \param periods ...
1386 : ! **************************************************************************************************
1387 8725647 : SUBROUTINE mp_cart_get(comm, dims, task_coor, periods)
1388 :
1389 : CLASS(mp_cart_type), INTENT(IN) :: comm
1390 : INTEGER, INTENT(OUT), OPTIONAL :: dims(comm%ndims), task_coor(comm%ndims)
1391 : LOGICAL, INTENT(out), OPTIONAL :: periods(comm%ndims)
1392 :
1393 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_get'
1394 :
1395 : INTEGER :: handle
1396 : #if defined(__parallel)
1397 : INTEGER :: ierr
1398 17451294 : INTEGER :: my_dims(comm%ndims), my_task_coor(comm%ndims)
1399 17451294 : LOGICAL :: my_periods(comm%ndims)
1400 : #endif
1401 :
1402 8725647 : CALL mp_timeset(routineN, handle)
1403 :
1404 : #if defined(__parallel)
1405 8725647 : CALL mpi_cart_get(comm%handle, comm%ndims, my_dims, my_periods, my_task_coor, ierr)
1406 8725647 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_get @ mp_cart_get")
1407 34903414 : IF (PRESENT(dims)) dims = my_dims
1408 34903414 : IF (PRESENT(task_coor)) task_coor = my_task_coor
1409 34903414 : IF (PRESENT(periods)) periods = my_periods
1410 : #else
1411 : MARK_USED(comm)
1412 : IF (PRESENT(task_coor)) task_coor = 0
1413 : IF (PRESENT(dims)) dims = 1
1414 : IF (PRESENT(periods)) periods = .FALSE.
1415 : #endif
1416 8725647 : CALL mp_timestop(handle)
1417 :
1418 8725647 : END SUBROUTINE mp_cart_get
1419 :
1420 0 : INTEGER ELEMENTAL FUNCTION mp_comm_get_ndims(comm)
1421 : CLASS(mp_comm_type), INTENT(IN) :: comm
1422 :
1423 0 : mp_comm_get_ndims = comm%ndims
1424 :
1425 0 : END FUNCTION
1426 :
1427 : ! **************************************************************************************************
1428 : !> \brief creates a cartesian communicator from any communicator
1429 : !> \param comm_old ...
1430 : !> \param ndims ...
1431 : !> \param dims ...
1432 : !> \param pos ...
1433 : !> \param comm_cart ...
1434 : ! **************************************************************************************************
1435 1639136 : SUBROUTINE mp_cart_create(comm_old, ndims, dims, comm_cart)
1436 :
1437 : CLASS(mp_comm_type), INTENT(IN) :: comm_old
1438 : INTEGER, INTENT(IN) :: ndims
1439 : INTEGER, INTENT(INOUT) :: dims(ndims)
1440 : CLASS(mp_cart_type), INTENT(OUT) :: comm_cart
1441 :
1442 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_create'
1443 :
1444 : INTEGER :: handle, ierr
1445 : #if defined(__parallel)
1446 1639136 : LOGICAL, DIMENSION(1:ndims) :: period
1447 : LOGICAL :: reorder
1448 : #endif
1449 :
1450 1639136 : ierr = 0
1451 1639136 : CALL mp_timeset(routineN, handle)
1452 :
1453 1639136 : comm_cart%handle = comm_old%handle
1454 : #if defined(__parallel)
1455 :
1456 4491400 : IF (ANY(dims == 0)) CALL mpi_dims_create(comm_old%num_pe, ndims, dims, ierr)
1457 1639136 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_cart_create")
1458 :
1459 : ! FIX ME. Quick hack to avoid problems with realspace grids for compilers
1460 : ! like IBM that actually reorder the processors when creating the new
1461 : ! communicator
1462 1639136 : reorder = .FALSE.
1463 4918234 : period = .TRUE.
1464 : CALL mpi_cart_create(comm_old%handle, ndims, dims, period, reorder, comm_cart%handle, &
1465 1639136 : ierr)
1466 1639136 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_create @ mp_cart_create")
1467 1639136 : CALL add_perf(perf_id=1, count=1)
1468 : #else
1469 : dims = 1
1470 : comm_cart%handle = mp_comm_default_handle
1471 : #endif
1472 1639136 : comm_cart%ndims = ndims
1473 1639136 : debug_comm_count = debug_comm_count + 1
1474 1639136 : CALL comm_cart%init()
1475 1639136 : CALL mp_timestop(handle)
1476 :
1477 1639136 : END SUBROUTINE mp_cart_create
1478 :
1479 : ! **************************************************************************************************
1480 : !> \brief wrapper to MPI_Cart_coords
1481 : !> \param comm ...
1482 : !> \param rank ...
1483 : !> \param coords ...
1484 : ! **************************************************************************************************
1485 58716 : SUBROUTINE mp_cart_coords(comm, rank, coords)
1486 :
1487 : CLASS(mp_cart_type), INTENT(IN) :: comm
1488 : INTEGER, INTENT(IN) :: rank
1489 : INTEGER, DIMENSION(:), INTENT(OUT) :: coords
1490 :
1491 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_coords'
1492 :
1493 : INTEGER :: handle, ierr, m
1494 :
1495 58716 : ierr = 0
1496 58716 : CALL mp_timeset(routineN, handle)
1497 :
1498 58716 : m = SIZE(coords)
1499 : #if defined(__parallel)
1500 58716 : CALL mpi_cart_coords(comm%handle, rank, m, coords, ierr)
1501 58716 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_coords @ mp_cart_coords")
1502 : #else
1503 : coords = 0
1504 : MARK_USED(rank)
1505 : MARK_USED(comm)
1506 : #endif
1507 58716 : CALL mp_timestop(handle)
1508 :
1509 58716 : END SUBROUTINE mp_cart_coords
1510 :
1511 : ! **************************************************************************************************
1512 : !> \brief wrapper to MPI_Comm_compare
1513 : !> \param comm1 ...
1514 : !> \param comm2 ...
1515 : !> \param res ...
1516 : ! **************************************************************************************************
1517 4520 : FUNCTION mp_comm_compare(comm1, comm2) RESULT(res)
1518 :
1519 : CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
1520 : INTEGER :: res
1521 :
1522 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_compare'
1523 :
1524 : INTEGER :: handle
1525 : #if defined(__parallel)
1526 : INTEGER :: ierr, iout
1527 : #endif
1528 :
1529 2260 : CALL mp_timeset(routineN, handle)
1530 :
1531 2260 : res = 0
1532 : #if defined(__parallel)
1533 2260 : CALL mpi_comm_compare(comm1%handle, comm2%handle, iout, ierr)
1534 2260 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_compare @ mp_comm_compare")
1535 : SELECT CASE (iout)
1536 : CASE (MPI_IDENT)
1537 2260 : res = mp_comm_ident
1538 : CASE (MPI_CONGRUENT)
1539 2260 : res = mp_comm_congruent
1540 : CASE (MPI_SIMILAR)
1541 0 : res = mp_comm_similar
1542 : CASE (MPI_UNEQUAL)
1543 0 : res = mp_comm_unequal
1544 : CASE default
1545 2260 : CPABORT("Unknown comparison state of the communicators!")
1546 : END SELECT
1547 : #else
1548 : MARK_USED(comm1)
1549 : MARK_USED(comm2)
1550 : #endif
1551 2260 : CALL mp_timestop(handle)
1552 :
1553 2260 : END FUNCTION mp_comm_compare
1554 :
1555 : ! **************************************************************************************************
1556 : !> \brief wrapper to MPI_Cart_sub
1557 : !> \param comm ...
1558 : !> \param rdim ...
1559 : !> \param sub_comm ...
1560 : ! **************************************************************************************************
1561 1652 : SUBROUTINE mp_cart_sub(comm, rdim, sub_comm)
1562 :
1563 : CLASS(mp_cart_type), INTENT(IN) :: comm
1564 : LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(IN) :: rdim
1565 : CLASS(mp_cart_type), INTENT(OUT) :: sub_comm
1566 :
1567 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_sub'
1568 :
1569 : INTEGER :: handle
1570 : #if defined(__parallel)
1571 : INTEGER :: ierr
1572 : #endif
1573 :
1574 1652 : CALL mp_timeset(routineN, handle)
1575 :
1576 : #if defined(__parallel)
1577 1652 : CALL mpi_cart_sub(comm%handle, rdim, sub_comm%handle, ierr)
1578 1652 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_sub @ mp_cart_sub")
1579 : #else
1580 : MARK_USED(comm)
1581 : MARK_USED(rdim)
1582 : sub_comm%handle = mp_comm_default_handle
1583 : #endif
1584 6608 : sub_comm%ndims = COUNT(rdim)
1585 1652 : debug_comm_count = debug_comm_count + 1
1586 1652 : CALL sub_comm%init()
1587 1652 : CALL mp_timestop(handle)
1588 :
1589 1652 : END SUBROUTINE mp_cart_sub
1590 :
1591 : ! **************************************************************************************************
1592 : !> \brief wrapper to MPI_Comm_free
1593 : !> \param comm ...
1594 : ! **************************************************************************************************
1595 3873741 : SUBROUTINE mp_comm_free(comm)
1596 :
1597 : CLASS(mp_comm_type), INTENT(INOUT) :: comm
1598 :
1599 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_free'
1600 :
1601 : INTEGER :: handle
1602 : LOGICAL :: free_comm
1603 : #if defined(__parallel)
1604 : INTEGER :: ierr
1605 : #endif
1606 :
1607 3873741 : free_comm = .TRUE.
1608 : SELECT TYPE (comm)
1609 : CLASS IS (mp_para_env_type)
1610 944706 : free_comm = .FALSE.
1611 944706 : IF (comm%ref_count <= 0) &
1612 0 : CPABORT("para_env%ref_count <= 0")
1613 944706 : comm%ref_count = comm%ref_count - 1
1614 944706 : IF (comm%ref_count <= 0) THEN
1615 193850 : free_comm = comm%owns_group
1616 : END IF
1617 : CLASS IS (mp_para_cart_type)
1618 144 : free_comm = .FALSE.
1619 144 : IF (comm%ref_count <= 0) &
1620 0 : CPABORT("para_cart%ref_count <= 0")
1621 144 : comm%ref_count = comm%ref_count - 1
1622 144 : IF (comm%ref_count <= 0) THEN
1623 144 : free_comm = comm%owns_group
1624 : END IF
1625 : END SELECT
1626 :
1627 3873741 : CALL mp_timeset(routineN, handle)
1628 :
1629 3873741 : IF (free_comm) THEN
1630 : #if defined(__parallel)
1631 3092774 : CALL mpi_comm_free(comm%handle, ierr)
1632 3092774 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_free @ mp_comm_free")
1633 : #else
1634 : comm%handle = mp_comm_null_handle
1635 : #endif
1636 3092774 : debug_comm_count = debug_comm_count - 1
1637 : END IF
1638 :
1639 : SELECT TYPE (comm)
1640 : CLASS IS (mp_cart_type)
1641 2189786 : DEALLOCATE (comm%periodic, comm%mepos_cart, comm%num_pe_cart)
1642 : END SELECT
1643 :
1644 3873741 : CALL mp_timestop(handle)
1645 :
1646 3873741 : END SUBROUTINE mp_comm_free
1647 :
1648 : ! **************************************************************************************************
1649 : !> \brief check whether the environment exists
1650 : !> \param para_env ...
1651 : !> \return ...
1652 : ! **************************************************************************************************
1653 805290 : ELEMENTAL LOGICAL FUNCTION mp_para_env_is_valid(para_env)
1654 : CLASS(mp_para_env_type), INTENT(IN) :: para_env
1655 :
1656 805290 : mp_para_env_is_valid = para_env%ref_count > 0
1657 :
1658 805290 : END FUNCTION mp_para_env_is_valid
1659 :
1660 : ! **************************************************************************************************
1661 : !> \brief increase the reference counter but ensure that you free it later
1662 : !> \param para_env ...
1663 : ! **************************************************************************************************
1664 750856 : ELEMENTAL SUBROUTINE mp_para_env_retain(para_env)
1665 : CLASS(mp_para_env_type), INTENT(INOUT) :: para_env
1666 :
1667 750856 : para_env%ref_count = para_env%ref_count + 1
1668 :
1669 750856 : END SUBROUTINE mp_para_env_retain
1670 :
1671 : ! **************************************************************************************************
1672 : !> \brief check whether the given environment is valid, i.e. existent
1673 : !> \param cart ...
1674 : !> \return ...
1675 : ! **************************************************************************************************
1676 144 : ELEMENTAL LOGICAL FUNCTION mp_para_cart_is_valid(cart)
1677 : CLASS(mp_para_cart_type), INTENT(IN) :: cart
1678 :
1679 144 : mp_para_cart_is_valid = cart%ref_count > 0
1680 :
1681 144 : END FUNCTION mp_para_cart_is_valid
1682 :
1683 : ! **************************************************************************************************
1684 : !> \brief increase the reference counter, don't forget to free it later
1685 : !> \param cart ...
1686 : ! **************************************************************************************************
1687 0 : ELEMENTAL SUBROUTINE mp_para_cart_retain(cart)
1688 : CLASS(mp_para_cart_type), INTENT(INOUT) :: cart
1689 :
1690 0 : cart%ref_count = cart%ref_count + 1
1691 :
1692 0 : END SUBROUTINE mp_para_cart_retain
1693 :
1694 : ! **************************************************************************************************
1695 : !> \brief wrapper to MPI_Comm_dup
1696 : !> \param comm1 ...
1697 : !> \param comm2 ...
1698 : ! **************************************************************************************************
1699 579628 : SUBROUTINE mp_comm_dup(comm1, comm2)
1700 :
1701 : CLASS(mp_comm_type), INTENT(IN) :: comm1
1702 : CLASS(mp_comm_type), INTENT(OUT) :: comm2
1703 :
1704 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_dup'
1705 :
1706 : INTEGER :: handle
1707 : #if defined(__parallel)
1708 : INTEGER :: ierr
1709 : #endif
1710 :
1711 579628 : CALL mp_timeset(routineN, handle)
1712 :
1713 : #if defined(__parallel)
1714 579628 : CALL mpi_comm_dup(comm1%handle, comm2%handle, ierr)
1715 579628 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_dup @ mp_comm_dup")
1716 : #else
1717 : MARK_USED(comm1)
1718 : comm2%handle = mp_comm_default_handle
1719 : #endif
1720 579628 : comm2%ndims = comm1%ndims
1721 579628 : debug_comm_count = debug_comm_count + 1
1722 579628 : CALL comm2%init()
1723 579628 : CALL mp_timestop(handle)
1724 :
1725 579628 : END SUBROUTINE mp_comm_dup
1726 :
1727 : ! **************************************************************************************************
1728 : !> \brief Implements a simple assignment function to overload the assignment operator
1729 : !> \param comm_new communicator on the r.h.s. of the assignment operator
1730 : !> \param comm_old communicator on the l.h.s. of the assignment operator
1731 : ! **************************************************************************************************
1732 8821147 : ELEMENTAL IMPURE SUBROUTINE mp_comm_assign(comm_new, comm_old)
1733 : CLASS(mp_comm_type), INTENT(IN) :: comm_old
1734 : CLASS(mp_comm_type), INTENT(OUT) :: comm_new
1735 :
1736 8821147 : comm_new%handle = comm_old%handle
1737 8821147 : comm_new%ndims = comm_old%ndims
1738 8821147 : CALL comm_new%init(.FALSE.)
1739 8821147 : END SUBROUTINE
1740 :
1741 : ! **************************************************************************************************
1742 : !> \brief check whether the local process is the source process
1743 : !> \param para_env ...
1744 : !> \return ...
1745 : ! **************************************************************************************************
1746 14385544 : ELEMENTAL LOGICAL FUNCTION mp_comm_is_source(comm)
1747 : CLASS(mp_comm_type), INTENT(IN) :: comm
1748 :
1749 14385544 : mp_comm_is_source = comm%source == comm%mepos
1750 :
1751 14385544 : END FUNCTION mp_comm_is_source
1752 :
1753 : ! **************************************************************************************************
1754 : !> \brief Initializes the communicator (mostly relevant for its derived classes)
1755 : !> \param comm ...
1756 : ! **************************************************************************************************
1757 17369026 : ELEMENTAL IMPURE SUBROUTINE mp_comm_init(comm, owns_group)
1758 : CLASS(mp_comm_type), INTENT(INOUT) :: comm
1759 : LOGICAL, INTENT(IN), OPTIONAL :: owns_group
1760 :
1761 17369026 : IF (comm%handle MPI_GET_COMP /= mp_comm_null_handle MPI_GET_COMP) THEN
1762 17190542 : comm%source = 0
1763 17190542 : CALL comm%get_size(comm%num_pe)
1764 17190542 : CALL comm%get_rank(comm%mepos)
1765 : END IF
1766 :
1767 : SELECT TYPE (comm)
1768 : CLASS IS (mp_cart_type)
1769 8725647 : IF (ALLOCATED(comm%periodic)) DEALLOCATE (comm%periodic)
1770 8725647 : IF (ALLOCATED(comm%mepos_cart)) DEALLOCATE (comm%mepos_cart)
1771 8725647 : IF (ALLOCATED(comm%num_pe_cart)) DEALLOCATE (comm%num_pe_cart)
1772 :
1773 : ASSOCIATE (ndims => comm%ndims)
1774 :
1775 0 : ALLOCATE (comm%periodic(ndims), comm%mepos_cart(ndims), &
1776 61079529 : comm%num_pe_cart(ndims))
1777 : END ASSOCIATE
1778 :
1779 26177767 : comm%mepos_cart = 0
1780 26177767 : comm%periodic = .FALSE.
1781 8725647 : IF (comm%handle MPI_GET_COMP /= mp_comm_null_handle MPI_GET_COMP) THEN
1782 : CALL comm%get_info_cart(comm%num_pe_cart, comm%mepos_cart, &
1783 8725647 : comm%periodic)
1784 : END IF
1785 : END SELECT
1786 :
1787 : SELECT TYPE (comm)
1788 : CLASS IS (mp_para_env_type)
1789 203134 : IF (PRESENT(owns_group)) comm%owns_group = owns_group
1790 203134 : comm%ref_count = 1
1791 : CLASS IS (mp_para_cart_type)
1792 144 : IF (PRESENT(owns_group)) comm%owns_group = owns_group
1793 144 : comm%ref_count = 1
1794 : END SELECT
1795 :
1796 17369026 : END SUBROUTINE
1797 :
1798 : ! **************************************************************************************************
1799 : !> \brief creates a new para environment
1800 : !> \param para_env the new parallel environment
1801 : !> \param group the id of the actual mpi_group
1802 : !> \par History
1803 : !> 08.2002 created [fawzi]
1804 : !> \author Fawzi Mohamed
1805 : ! **************************************************************************************************
1806 0 : SUBROUTINE mp_para_env_create(para_env, group)
1807 : TYPE(mp_para_env_type), POINTER :: para_env
1808 : CLASS(mp_comm_type), INTENT(in) :: group
1809 :
1810 0 : IF (ASSOCIATED(para_env)) &
1811 0 : CPABORT("The passed para_env must not be associated!")
1812 0 : ALLOCATE (para_env)
1813 0 : para_env%mp_comm_type = group
1814 0 : CALL para_env%init()
1815 0 : END SUBROUTINE mp_para_env_create
1816 :
1817 : ! **************************************************************************************************
1818 : !> \brief releases the para object (to be called when you don't want anymore
1819 : !> the shared copy of this object)
1820 : !> \param para_env the new group
1821 : !> \par History
1822 : !> 08.2002 created [fawzi]
1823 : !> \author Fawzi Mohamed
1824 : !> \note
1825 : !> to avoid circular dependencies cp_log_handling has a private copy
1826 : !> of this method (see cp_log_handling:my_mp_para_env_release)!
1827 : ! **************************************************************************************************
1828 813989 : SUBROUTINE mp_para_env_release(para_env)
1829 : TYPE(mp_para_env_type), POINTER :: para_env
1830 :
1831 813989 : IF (ASSOCIATED(para_env)) THEN
1832 784013 : CALL para_env%free()
1833 784013 : IF (.NOT. para_env%is_valid()) DEALLOCATE (para_env)
1834 : END IF
1835 813989 : NULLIFY (para_env)
1836 813989 : END SUBROUTINE mp_para_env_release
1837 :
1838 : ! **************************************************************************************************
1839 : !> \brief creates a cart (multidimensional parallel environment)
1840 : !> \param cart the cart environment to create
1841 : !> \param group the mpi communicator
1842 : !> \author fawzi
1843 : ! **************************************************************************************************
1844 0 : SUBROUTINE mp_para_cart_create(cart, group)
1845 : TYPE(mp_para_cart_type), POINTER, INTENT(OUT) :: cart
1846 : CLASS(mp_comm_type), INTENT(in) :: group
1847 :
1848 0 : IF (ASSOCIATED(cart)) &
1849 0 : CPABORT("The passed para_cart must not be associated!")
1850 0 : ALLOCATE (cart)
1851 0 : cart%mp_cart_type = group
1852 0 : CALL cart%init()
1853 :
1854 0 : END SUBROUTINE mp_para_cart_create
1855 :
1856 : ! **************************************************************************************************
1857 : !> \brief releases the given cart
1858 : !> \param cart the cart to release
1859 : !> \author fawzi
1860 : ! **************************************************************************************************
1861 144 : SUBROUTINE mp_para_cart_release(cart)
1862 : TYPE(mp_para_cart_type), POINTER :: cart
1863 :
1864 144 : IF (ASSOCIATED(cart)) THEN
1865 144 : CALL cart%free()
1866 144 : IF (.NOT. cart%is_valid()) DEALLOCATE (cart)
1867 : END IF
1868 144 : NULLIFY (cart)
1869 144 : END SUBROUTINE mp_para_cart_release
1870 :
1871 : ! **************************************************************************************************
1872 : !> \brief wrapper to MPI_Group_translate_ranks
1873 : !> \param comm1 ...
1874 : !> \param comm2 ...
1875 : !> \param rank ...
1876 : ! **************************************************************************************************
1877 2819134 : SUBROUTINE mp_rank_compare(comm1, comm2, rank)
1878 :
1879 : CLASS(mp_comm_type), INTENT(IN) :: comm1, comm2
1880 : INTEGER, DIMENSION(:), CONTIGUOUS, INTENT(OUT) :: rank
1881 :
1882 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_rank_compare'
1883 :
1884 : INTEGER :: handle
1885 : #if defined(__parallel)
1886 : INTEGER :: i, ierr, n, n1, n2
1887 2819134 : INTEGER, ALLOCATABLE, DIMENSION(:) :: rin
1888 : MPI_GROUP_TYPE :: g1, g2
1889 : #endif
1890 :
1891 2819134 : CALL mp_timeset(routineN, handle)
1892 :
1893 8457402 : rank = 0
1894 : #if defined(__parallel)
1895 2819134 : CALL mpi_comm_size(comm1%handle, n1, ierr)
1896 2819134 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
1897 2819134 : CALL mpi_comm_size(comm2%handle, n2, ierr)
1898 2819134 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_size @ mp_rank_compare")
1899 2819134 : n = MAX(n1, n2)
1900 2819134 : CALL mpi_comm_group(comm1%handle, g1, ierr)
1901 2819134 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
1902 2819134 : CALL mpi_comm_group(comm2%handle, g2, ierr)
1903 2819134 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_comm_group @ mp_rank_compare")
1904 8457402 : ALLOCATE (rin(0:n - 1), STAT=ierr)
1905 2819134 : IF (ierr /= 0) &
1906 0 : CPABORT("allocate @ mp_rank_compare")
1907 8457402 : DO i = 0, n - 1
1908 8457402 : rin(i) = i
1909 : END DO
1910 2819134 : CALL mpi_group_translate_ranks(g1, n, rin, g2, rank, ierr)
1911 2819134 : IF (ierr /= 0) CALL mp_stop(ierr, &
1912 0 : "mpi_group_translate_rank @ mp_rank_compare")
1913 2819134 : CALL mpi_group_free(g1, ierr)
1914 2819134 : IF (ierr /= 0) &
1915 0 : CPABORT("group_free @ mp_rank_compare")
1916 2819134 : CALL mpi_group_free(g2, ierr)
1917 2819134 : IF (ierr /= 0) &
1918 0 : CPABORT("group_free @ mp_rank_compare")
1919 2819134 : DEALLOCATE (rin)
1920 : #else
1921 : MARK_USED(comm1)
1922 : MARK_USED(comm2)
1923 : #endif
1924 2819134 : CALL mp_timestop(handle)
1925 :
1926 19733938 : END SUBROUTINE mp_rank_compare
1927 :
1928 : ! **************************************************************************************************
1929 : !> \brief wrapper to MPI_Dims_create
1930 : !> \param nodes ...
1931 : !> \param dims ...
1932 : ! **************************************************************************************************
1933 784452 : SUBROUTINE mp_dims_create(nodes, dims)
1934 :
1935 : INTEGER, INTENT(IN) :: nodes
1936 : INTEGER, DIMENSION(:), INTENT(INOUT) :: dims
1937 :
1938 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_dims_create'
1939 :
1940 : INTEGER :: handle, ndim
1941 : #if defined(__parallel)
1942 : INTEGER :: ierr
1943 : #endif
1944 :
1945 784452 : CALL mp_timeset(routineN, handle)
1946 :
1947 784452 : ndim = SIZE(dims)
1948 : #if defined(__parallel)
1949 784452 : IF (ANY(dims == 0)) CALL mpi_dims_create(nodes, ndim, dims, ierr)
1950 784452 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_dims_create @ mp_dims_create")
1951 : #else
1952 : dims = 1
1953 : MARK_USED(nodes)
1954 : #endif
1955 784452 : CALL mp_timestop(handle)
1956 :
1957 784452 : END SUBROUTINE mp_dims_create
1958 :
1959 : ! **************************************************************************************************
1960 : !> \brief wrapper to MPI_Cart_rank
1961 : !> \param comm ...
1962 : !> \param pos ...
1963 : !> \param rank ...
1964 : ! **************************************************************************************************
1965 4363890 : SUBROUTINE mp_cart_rank(comm, pos, rank)
1966 : CLASS(mp_cart_type), INTENT(IN) :: comm
1967 : INTEGER, DIMENSION(:), INTENT(IN) :: pos
1968 : INTEGER, INTENT(OUT) :: rank
1969 :
1970 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_cart_rank'
1971 :
1972 : INTEGER :: handle
1973 : #if defined(__parallel)
1974 : INTEGER :: ierr
1975 : #endif
1976 :
1977 4363890 : CALL mp_timeset(routineN, handle)
1978 :
1979 : #if defined(__parallel)
1980 4363890 : CALL mpi_cart_rank(comm%handle, pos, rank, ierr)
1981 4363890 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_cart_rank @ mp_cart_rank")
1982 : #else
1983 : rank = 0
1984 : MARK_USED(comm)
1985 : MARK_USED(pos)
1986 : #endif
1987 4363890 : CALL mp_timestop(handle)
1988 :
1989 4363890 : END SUBROUTINE mp_cart_rank
1990 :
1991 : ! **************************************************************************************************
1992 : !> \brief waits for completion of the given request
1993 : !> \param request ...
1994 : !> \par History
1995 : !> 08.2003 created [f&j]
1996 : !> \author joost & fawzi
1997 : !> \note
1998 : !> see isendrecv
1999 : ! **************************************************************************************************
2000 16572 : SUBROUTINE mp_wait(request)
2001 : CLASS(mp_request_type), INTENT(inout) :: request
2002 :
2003 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_wait'
2004 :
2005 : INTEGER :: handle
2006 : #if defined(__parallel)
2007 : INTEGER :: ierr
2008 : #endif
2009 :
2010 8286 : CALL mp_timeset(routineN, handle)
2011 :
2012 : #if defined(__parallel)
2013 :
2014 8286 : CALL mpi_wait(request%handle, MPI_STATUS_IGNORE, ierr)
2015 8286 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_wait @ mp_wait")
2016 :
2017 8286 : CALL add_perf(perf_id=9, count=1)
2018 : #else
2019 : request%handle = mp_request_null_handle
2020 : #endif
2021 8286 : CALL mp_timestop(handle)
2022 8286 : END SUBROUTINE mp_wait
2023 :
2024 : ! **************************************************************************************************
2025 : !> \brief waits for completion of the given requests
2026 : !> \param requests ...
2027 : !> \par History
2028 : !> 08.2003 created [f&j]
2029 : !> \author joost & fawzi
2030 : !> \note
2031 : !> see isendrecv
2032 : ! **************************************************************************************************
2033 1719654 : SUBROUTINE mp_waitall_1(requests)
2034 : TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2035 :
2036 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_1'
2037 :
2038 : INTEGER :: handle
2039 : #if defined(__parallel)
2040 : INTEGER :: count, ierr
2041 : #endif
2042 :
2043 1719654 : CALL mp_timeset(routineN, handle)
2044 : #if defined(__parallel)
2045 1719654 : count = SIZE(requests)
2046 1719654 : CALL mpi_waitall_internal(count, requests, ierr)
2047 1719654 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_1")
2048 1719654 : CALL add_perf(perf_id=9, count=1)
2049 : #else
2050 : requests = mp_request_null
2051 : #endif
2052 1719654 : CALL mp_timestop(handle)
2053 1719654 : END SUBROUTINE mp_waitall_1
2054 :
2055 : ! **************************************************************************************************
2056 : !> \brief waits for completion of the given requests
2057 : !> \param requests ...
2058 : !> \par History
2059 : !> 08.2003 created [f&j]
2060 : !> \author joost & fawzi
2061 : ! **************************************************************************************************
2062 755811 : SUBROUTINE mp_waitall_2(requests)
2063 : TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2064 :
2065 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitall_2'
2066 :
2067 : INTEGER :: handle
2068 : #if defined(__parallel)
2069 : INTEGER :: count, ierr
2070 : #endif
2071 :
2072 755811 : CALL mp_timeset(routineN, handle)
2073 : #if defined(__parallel)
2074 2267433 : count = SIZE(requests)
2075 4224679 : CALL mpi_waitall_internal(count, requests, ierr)
2076 755811 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitall @ mp_waitall_2")
2077 755811 : CALL add_perf(perf_id=9, count=1)
2078 : #else
2079 : requests = mp_request_null
2080 : #endif
2081 755811 : CALL mp_timestop(handle)
2082 755811 : END SUBROUTINE mp_waitall_2
2083 :
2084 : ! **************************************************************************************************
2085 : !> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2086 : !> the issue is with the rank or requests
2087 : !> \param count ...
2088 : !> \param array_of_requests ...
2089 : !> \param ierr ...
2090 : !> \author Joost VandeVondele
2091 : ! **************************************************************************************************
2092 : #if defined(__parallel)
2093 2475465 : SUBROUTINE mpi_waitall_internal(count, array_of_requests, ierr)
2094 : INTEGER, INTENT(in) :: count
2095 : TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2096 : INTEGER, INTENT(out) :: ierr
2097 :
2098 2475465 : MPI_REQUEST_TYPE, ALLOCATABLE, DIMENSION(:), TARGET :: request_handles
2099 :
2100 20162164 : ALLOCATE (request_handles(count), SOURCE=array_of_requests(1:count)%handle)
2101 2475465 : CALL mpi_waitall(count, request_handles, MPI_STATUSES_IGNORE, ierr)
2102 8861815 : array_of_requests(1:count)%handle = request_handles(:)
2103 2475465 : DEALLOCATE (request_handles)
2104 :
2105 2475465 : END SUBROUTINE mpi_waitall_internal
2106 : #endif
2107 :
2108 : ! **************************************************************************************************
2109 : !> \brief waits for completion of any of the given requests
2110 : !> \param requests ...
2111 : !> \param completed ...
2112 : !> \par History
2113 : !> 09.2008 created
2114 : !> \author Iain Bethune (c) The Numerical Algorithms Group (NAG) Ltd, 2008 on behalf of the HECToR project
2115 : ! **************************************************************************************************
2116 12536 : SUBROUTINE mp_waitany(requests, completed)
2117 : TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2118 : INTEGER, INTENT(out) :: completed
2119 :
2120 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_waitany'
2121 :
2122 : INTEGER :: handle
2123 : #if defined(__parallel)
2124 : INTEGER :: count, ierr
2125 12536 : MPI_REQUEST_TYPE, ALLOCATABLE, DIMENSION(:) :: request_handles
2126 : #endif
2127 :
2128 12536 : CALL mp_timeset(routineN, handle)
2129 :
2130 : #if defined(__parallel)
2131 12536 : count = SIZE(requests)
2132 : ! Convert CP2K's request_handles to the plain handle for the library
2133 87752 : ALLOCATE (request_handles(count), SOURCE=requests(1:count)%handle)
2134 :
2135 12536 : CALL mpi_waitany(count, request_handles, completed, MPI_STATUS_IGNORE, ierr)
2136 12536 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_waitany @ mp_waitany")
2137 :
2138 : ! Convert the plain handles to CP2K handles
2139 37608 : requests(1:count)%handle = request_handles(:)
2140 12536 : DEALLOCATE (request_handles)
2141 12536 : CALL add_perf(perf_id=9, count=1)
2142 : #else
2143 : requests = mp_request_null
2144 : completed = 1
2145 : #endif
2146 12536 : CALL mp_timestop(handle)
2147 25072 : END SUBROUTINE mp_waitany
2148 :
2149 : ! **************************************************************************************************
2150 : !> \brief Tests for completion of the given requests.
2151 : !> \brief We use mpi_test so that we can use a single status.
2152 : !> \param requests the list of requests to test
2153 : !> \return logical which determines if requests are complete
2154 : !> \par History
2155 : !> 3.2016 adapted to any shape [Nico Holmberg]
2156 : !> \author Alfio Lazzaro
2157 : ! **************************************************************************************************
2158 6400 : FUNCTION mp_testall_tv(requests) RESULT(flag)
2159 : TYPE(mp_request_type), DIMENSION(:), INTENT(INOUT) :: requests
2160 : LOGICAL :: flag
2161 :
2162 : #if defined(__parallel)
2163 : INTEGER :: i, ierr
2164 : LOGICAL, DIMENSION(:), POINTER :: flags
2165 : #endif
2166 :
2167 6400 : flag = .TRUE.
2168 :
2169 : #if defined(__parallel)
2170 19200 : ALLOCATE (flags(SIZE(requests)))
2171 25600 : DO i = 1, SIZE(requests)
2172 19200 : CALL mpi_test(requests(i)%handle, flags(i), MPI_STATUS_IGNORE, ierr)
2173 19200 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testall @ mp_testall_tv")
2174 45377 : flag = flag .AND. flags(i)
2175 : END DO
2176 6400 : DEALLOCATE (flags)
2177 : #else
2178 : requests = mp_request_null
2179 : #endif
2180 6400 : END FUNCTION mp_testall_tv
2181 :
2182 : ! **************************************************************************************************
2183 : !> \brief Tests for completion of the given request.
2184 : !> \param request the request
2185 : !> \param flag logical which determines if the request is completed
2186 : !> \par History
2187 : !> 3.2016 created
2188 : !> \author Nico Holmberg
2189 : ! **************************************************************************************************
2190 104 : FUNCTION mp_test_1(request) RESULT(flag)
2191 : CLASS(mp_request_type), INTENT(inout) :: request
2192 : LOGICAL :: flag
2193 :
2194 : #if defined(__parallel)
2195 : INTEGER :: ierr
2196 :
2197 104 : CALL mpi_test(request%handle, flag, MPI_STATUS_IGNORE, ierr)
2198 104 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_test @ mp_test_1")
2199 : #else
2200 : MARK_USED(request)
2201 : flag = .TRUE.
2202 : #endif
2203 104 : END FUNCTION mp_test_1
2204 :
2205 : ! **************************************************************************************************
2206 : !> \brief tests for completion of the given requests
2207 : !> \param requests ...
2208 : !> \param completed ...
2209 : !> \param flag ...
2210 : !> \par History
2211 : !> 08.2011 created
2212 : !> \author Iain Bethune
2213 : ! **************************************************************************************************
2214 0 : SUBROUTINE mp_testany_1(requests, completed, flag)
2215 : TYPE(mp_request_type), DIMENSION(:), INTENT(inout) :: requests
2216 : INTEGER, INTENT(out), OPTIONAL :: completed
2217 : LOGICAL, INTENT(out), OPTIONAL :: flag
2218 :
2219 : #if defined(__parallel)
2220 : INTEGER :: completed_l, count, ierr
2221 : LOGICAL :: flag_l
2222 :
2223 0 : count = SIZE(requests)
2224 :
2225 0 : CALL mpi_testany_internal(count, requests, completed_l, flag_l, MPI_STATUS_IGNORE, ierr)
2226 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_1 @ mp_testany")
2227 :
2228 0 : IF (PRESENT(completed)) completed = completed_l
2229 0 : IF (PRESENT(flag)) flag = flag_l
2230 : #else
2231 : MARK_USED(requests)
2232 : IF (PRESENT(completed)) completed = 1
2233 : IF (PRESENT(flag)) flag = .TRUE.
2234 : #endif
2235 0 : END SUBROUTINE mp_testany_1
2236 :
2237 : ! **************************************************************************************************
2238 : !> \brief tests for completion of the given requests
2239 : !> \param requests ...
2240 : !> \param completed ...
2241 : !> \param flag ...
2242 : !> \par History
2243 : !> 08.2011 created
2244 : !> \author Iain Bethune
2245 : ! **************************************************************************************************
2246 0 : SUBROUTINE mp_testany_2(requests, completed, flag)
2247 : TYPE(mp_request_type), DIMENSION(:, :), INTENT(inout) :: requests
2248 : INTEGER, INTENT(out), OPTIONAL :: completed
2249 : LOGICAL, INTENT(out), OPTIONAL :: flag
2250 :
2251 : #if defined(__parallel)
2252 : INTEGER :: completed_l, count, ierr
2253 : LOGICAL :: flag_l
2254 :
2255 0 : count = SIZE(requests)
2256 :
2257 0 : CALL mpi_testany_internal(count, requests, completed_l, flag_l, MPI_STATUS_IGNORE, ierr)
2258 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_testany_2 @ mp_testany")
2259 :
2260 0 : IF (PRESENT(completed)) completed = completed_l
2261 0 : IF (PRESENT(flag)) flag = flag_l
2262 : #else
2263 : MARK_USED(requests)
2264 : IF (PRESENT(completed)) completed = 1
2265 : IF (PRESENT(flag)) flag = .TRUE.
2266 : #endif
2267 0 : END SUBROUTINE mp_testany_2
2268 :
2269 : ! **************************************************************************************************
2270 : !> \brief wrapper needed to deal with interfaces as present in openmpi 1.8.1
2271 : !> the issue is with the rank or requests
2272 : !> \param count ...
2273 : !> \param array_of_requests ...
2274 : !> \param index ...
2275 : !> \param flag ...
2276 : !> \param status ...
2277 : !> \param ierr ...
2278 : !> \author Joost VandeVondele
2279 : ! **************************************************************************************************
2280 : #if defined(__parallel)
2281 0 : SUBROUTINE mpi_testany_internal(count, array_of_requests, index, flag, status, ierr)
2282 : INTEGER, INTENT(in) :: count
2283 : TYPE(mp_request_type), DIMENSION(count), INTENT(inout) :: array_of_requests
2284 : INTEGER, INTENT(out) :: index
2285 : LOGICAL, INTENT(out) :: flag
2286 : MPI_STATUS_TYPE, INTENT(out) :: status
2287 : INTEGER, INTENT(out) :: ierr
2288 :
2289 0 : MPI_REQUEST_TYPE, ALLOCATABLE, DIMENSION(:) :: request_handles
2290 :
2291 0 : ALLOCATE (request_handles(count), SOURCE=array_of_requests(1:count)%handle)
2292 0 : CALL mpi_testany(count, request_handles, index, flag, status, ierr)
2293 0 : array_of_requests(1:count)%handle = request_handles(:)
2294 0 : DEALLOCATE (request_handles)
2295 :
2296 0 : END SUBROUTINE mpi_testany_internal
2297 : #endif
2298 :
2299 : ! **************************************************************************************************
2300 : !> \brief the direct way to split a communicator each color is a sub_comm,
2301 : !> the rank order is according to the order in the orig comm
2302 : !> \param comm ...
2303 : !> \param sub_comm ...
2304 : !> \param color ...
2305 : !> \param key ...
2306 : !> \author Joost VandeVondele
2307 : ! **************************************************************************************************
2308 711136 : SUBROUTINE mp_comm_split_direct(comm, sub_comm, color, key)
2309 : CLASS(mp_comm_type), INTENT(in) :: comm
2310 : CLASS(mp_comm_type), INTENT(OUT) :: sub_comm
2311 : INTEGER, INTENT(in) :: color
2312 : INTEGER, INTENT(in), OPTIONAL :: key
2313 :
2314 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_comm_split_direct'
2315 :
2316 : INTEGER :: handle
2317 : #if defined(__parallel)
2318 : INTEGER :: ierr, my_key
2319 : #endif
2320 :
2321 711136 : CALL mp_timeset(routineN, handle)
2322 :
2323 : #if defined(__parallel)
2324 711136 : my_key = 0
2325 711136 : IF (PRESENT(key)) my_key = key
2326 711136 : CALL mpi_comm_split(comm%handle, color, my_key, sub_comm%handle, ierr)
2327 711136 : IF (ierr /= mpi_success) CALL mp_stop(ierr, routineN)
2328 711136 : CALL add_perf(perf_id=10, count=1)
2329 : #else
2330 : sub_comm%handle = mp_comm_default_handle
2331 : MARK_USED(comm)
2332 : MARK_USED(color)
2333 : MARK_USED(key)
2334 : #endif
2335 711136 : debug_comm_count = debug_comm_count + 1
2336 711136 : CALL sub_comm%init()
2337 711136 : CALL mp_timestop(handle)
2338 :
2339 711136 : END SUBROUTINE mp_comm_split_direct
2340 : ! **************************************************************************************************
2341 : !> \brief splits the given communicator in group in subgroups trying to organize
2342 : !> them in a way that the communication within each subgroup is
2343 : !> efficient (but not necessarily the communication between subgroups)
2344 : !> \param comm the mpi communicator that you want to split
2345 : !> \param sub_comm the communicator for the subgroup (created, needs to be freed later)
2346 : !> \param ngroups actual number of groups
2347 : !> \param group_distribution input : allocated with array with the nprocs entries (0 .. nprocs-1)
2348 : !> \param subgroup_min_size the minimum size of the subgroup
2349 : !> \param n_subgroups the number of subgroups wanted
2350 : !> \param group_partition n_subgroups sized array containing the number of cpus wanted per group.
2351 : !> should match the total number of cpus (only used if present and associated) (0..ngroups-1)
2352 : !> \param stride create groups using a stride (default=1) through the ranks of the comm to be split.
2353 : !> \par History
2354 : !> 10.2003 created [fawzi]
2355 : !> 02.2004 modified [Joost VandeVondele]
2356 : !> \author Fawzi Mohamed
2357 : !> \note
2358 : !> at least one of subgroup_min_size and n_subgroups is needed,
2359 : !> the other default to the value needed to use most processors.
2360 : !> if less cpus are present than needed for subgroup min size, n_subgroups,
2361 : !> just one comm is created that contains all cpus
2362 : ! **************************************************************************************************
2363 160478 : SUBROUTINE mp_comm_split(comm, sub_comm, ngroups, group_distribution, &
2364 160478 : subgroup_min_size, n_subgroups, group_partition, stride)
2365 : CLASS(mp_comm_type), INTENT(in) :: comm
2366 : CLASS(mp_comm_type), INTENT(out) :: sub_comm
2367 : INTEGER, INTENT(out) :: ngroups
2368 : INTEGER, DIMENSION(0:), INTENT(INOUT) :: group_distribution
2369 : INTEGER, INTENT(in), OPTIONAL :: subgroup_min_size, &
2370 : n_subgroups
2371 : INTEGER, DIMENSION(0:), INTENT(IN), OPTIONAL :: group_partition
2372 : INTEGER, OPTIONAL, INTENT(IN) :: stride
2373 :
2374 : CHARACTER(LEN=*), PARAMETER :: routineN = 'mp_comm_split', &
2375 : routineP = moduleN//':'//routineN
2376 :
2377 : INTEGER :: handle, mepos, nnodes
2378 : #if defined(__parallel)
2379 : INTEGER :: color, i, ierr, j, k, &
2380 : my_subgroup_min_size, &
2381 : istride, local_stride, irank
2382 160478 : INTEGER, DIMENSION(:), ALLOCATABLE :: rank_permutation
2383 : #endif
2384 :
2385 160478 : CALL mp_timeset(routineN, handle)
2386 :
2387 : ! actual number of groups
2388 :
2389 160478 : IF (.NOT. PRESENT(subgroup_min_size) .AND. .NOT. PRESENT(n_subgroups)) THEN
2390 0 : CPABORT(routineP//" missing arguments")
2391 : END IF
2392 160478 : IF (PRESENT(subgroup_min_size) .AND. PRESENT(n_subgroups)) THEN
2393 0 : CPABORT(routineP//" too many arguments")
2394 : END IF
2395 :
2396 160478 : CALL comm%get_size(nnodes)
2397 160478 : CALL comm%get_rank(mepos)
2398 :
2399 160478 : IF (UBOUND(group_distribution, 1) /= nnodes - 1) THEN
2400 0 : CPABORT(routineP//" group_distribution wrong bounds")
2401 : END IF
2402 :
2403 : #if defined(__parallel)
2404 160478 : IF (PRESENT(subgroup_min_size)) THEN
2405 144 : IF (subgroup_min_size < 0 .OR. subgroup_min_size > nnodes) THEN
2406 0 : CPABORT(routineP//" subgroup_min_size too small or too large")
2407 : END IF
2408 144 : ngroups = nnodes/subgroup_min_size
2409 144 : my_subgroup_min_size = subgroup_min_size
2410 : ELSE ! n_subgroups
2411 160334 : IF (n_subgroups <= 0) THEN
2412 0 : CPABORT(routineP//" n_subgroups too small")
2413 : END IF
2414 160334 : IF (nnodes/n_subgroups > 0) THEN ! we have a least one cpu per group
2415 156711 : ngroups = n_subgroups
2416 : ELSE ! well, only one group then
2417 3623 : ngroups = 1
2418 : END IF
2419 160334 : my_subgroup_min_size = nnodes/ngroups
2420 : END IF
2421 :
2422 : ! rank_permutation: is a permutation of ranks, so that groups are not necessarily continuous in rank of the master group
2423 : ! while the order is not critical (we only color ranks), it can e.g. be used to make groups that have just 1 rank per node
2424 : ! (by setting stride equal to the number of mpi ranks per node), or by sharing a node between two groups (stride 2).
2425 481434 : ALLOCATE (rank_permutation(0:nnodes - 1))
2426 160478 : local_stride = 1
2427 160478 : IF (PRESENT(stride)) local_stride = stride
2428 160478 : k = 0
2429 320956 : DO istride = 1, local_stride
2430 320956 : DO irank = istride - 1, nnodes - 1, local_stride
2431 317332 : rank_permutation(k) = irank
2432 317332 : k = k + 1
2433 : END DO
2434 : END DO
2435 :
2436 477810 : DO i = 0, nnodes - 1
2437 477810 : group_distribution(rank_permutation(i)) = MIN(i/my_subgroup_min_size, ngroups - 1)
2438 : END DO
2439 : ! even the user gave a partition, see if we can use it to overwrite this choice
2440 160478 : IF (PRESENT(group_partition)) THEN
2441 684097 : IF (ALL(group_partition > 0) .AND. (SUM(group_partition) == nnodes) .AND. (ngroups == SIZE(group_partition))) THEN
2442 90 : k = 0
2443 90 : DO i = 0, SIZE(group_partition) - 1
2444 150 : DO j = 1, group_partition(i)
2445 60 : group_distribution(rank_permutation(k)) = i
2446 120 : k = k + 1
2447 : END DO
2448 : END DO
2449 : ELSE
2450 : ! just ignore silently as we have reasonable defaults. Probably a warning would not be to bad
2451 : END IF
2452 : END IF
2453 160478 : DEALLOCATE (rank_permutation)
2454 160478 : color = group_distribution(mepos)
2455 160478 : CALL mpi_comm_split(comm%handle, color, 0, sub_comm%handle, ierr)
2456 160478 : IF (ierr /= mpi_success) CALL mp_stop(ierr, "in "//routineP//" split")
2457 :
2458 160478 : CALL add_perf(perf_id=10, count=1)
2459 : #else
2460 : sub_comm%handle = mp_comm_default_handle
2461 : group_distribution(0) = 0
2462 : ngroups = 1
2463 : MARK_USED(comm)
2464 : MARK_USED(stride)
2465 : MARK_USED(group_partition)
2466 : #endif
2467 160478 : debug_comm_count = debug_comm_count + 1
2468 160478 : CALL sub_comm%init()
2469 160478 : CALL mp_timestop(handle)
2470 :
2471 320956 : END SUBROUTINE mp_comm_split
2472 :
2473 : ! **************************************************************************************************
2474 : !> \brief probes for an incoming message with any tag
2475 : !> \param[inout] source the source of the possible incoming message,
2476 : !> if MP_ANY_SOURCE it is a blocking one and return value is the source
2477 : !> of the next incoming message
2478 : !> if source is a different value it is a non-blocking probe returning
2479 : !> MP_ANY_SOURCE if there is no incoming message
2480 : !> \param[in] comm the communicator
2481 : !> \param[out] tag the tag of the incoming message
2482 : !> \author Mandes
2483 : ! **************************************************************************************************
2484 1538329 : SUBROUTINE mp_probe(source, comm, tag)
2485 : INTEGER, INTENT(INOUT) :: source
2486 : CLASS(mp_comm_type), INTENT(IN) :: comm
2487 : INTEGER, INTENT(OUT) :: tag
2488 :
2489 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_probe'
2490 :
2491 : INTEGER :: handle
2492 : #if defined(__parallel)
2493 : INTEGER :: ierr
2494 : MPI_STATUS_TYPE :: status_single
2495 : LOGICAL :: flag
2496 : #endif
2497 :
2498 : ! ---------------------------------------------------------------------------
2499 :
2500 1538329 : CALL mp_timeset(routineN, handle)
2501 :
2502 : #if defined(__parallel)
2503 1538329 : IF (source == mp_any_source) THEN
2504 14 : CALL mpi_probe(mp_any_source, mp_any_tag, comm%handle, status_single, ierr)
2505 14 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_probe @ mp_probe")
2506 14 : source = status_single MPI_STATUS_EXTRACT(MPI_SOURCE)
2507 14 : tag = status_single MPI_STATUS_EXTRACT(MPI_TAG)
2508 : ELSE
2509 : flag = .FALSE.
2510 1538315 : CALL mpi_iprobe(source, mp_any_tag, comm%handle, flag, status_single, ierr)
2511 1538315 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_iprobe @ mp_probe")
2512 1538315 : IF (flag .EQV. .FALSE.) THEN
2513 1529199 : source = mp_any_source
2514 1529199 : tag = -1 !status_single(MPI_TAG) ! in case of flag==false status is undefined
2515 : ELSE
2516 9116 : tag = status_single MPI_STATUS_EXTRACT(MPI_TAG)
2517 : END IF
2518 : END IF
2519 : #else
2520 : tag = -1
2521 : MARK_USED(comm)
2522 : MARK_USED(source)
2523 : #endif
2524 1538329 : CALL mp_timestop(handle)
2525 1538329 : END SUBROUTINE mp_probe
2526 :
2527 : ! **************************************************************************************************
2528 : ! Here come the data routines with none of the standard data types.
2529 : ! **************************************************************************************************
2530 :
2531 : ! **************************************************************************************************
2532 : !> \brief ...
2533 : !> \param msg ...
2534 : !> \param source ...
2535 : !> \param comm ...
2536 : ! **************************************************************************************************
2537 719084 : SUBROUTINE mp_bcast_b(msg, source, comm)
2538 : LOGICAL, INTENT(INOUT) :: msg
2539 : INTEGER, INTENT(IN) :: source
2540 : CLASS(mp_comm_type), INTENT(IN) :: comm
2541 :
2542 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b'
2543 :
2544 : INTEGER :: handle
2545 : #if defined(__parallel)
2546 : INTEGER :: ierr, msglen
2547 : #endif
2548 :
2549 719084 : CALL mp_timeset(routineN, handle)
2550 :
2551 : #if defined(__parallel)
2552 719084 : msglen = 1
2553 719084 : CALL mpi_bcast(msg, msglen, MPI_LOGICAL, source, comm%handle, ierr)
2554 719084 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2555 719084 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2556 : #else
2557 : MARK_USED(msg)
2558 : MARK_USED(source)
2559 : MARK_USED(comm)
2560 : #endif
2561 719084 : CALL mp_timestop(handle)
2562 719084 : END SUBROUTINE mp_bcast_b
2563 :
2564 : ! **************************************************************************************************
2565 : !> \brief ...
2566 : !> \param msg ...
2567 : !> \param source ...
2568 : !> \param comm ...
2569 : ! **************************************************************************************************
2570 670619 : SUBROUTINE mp_bcast_b_src(msg, comm)
2571 : LOGICAL, INTENT(INOUT) :: msg
2572 : CLASS(mp_comm_type), INTENT(IN) :: comm
2573 :
2574 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_b_src'
2575 :
2576 : INTEGER :: handle
2577 : #if defined(__parallel)
2578 : INTEGER :: ierr, msglen
2579 : #endif
2580 :
2581 670619 : CALL mp_timeset(routineN, handle)
2582 :
2583 : #if defined(__parallel)
2584 670619 : msglen = 1
2585 670619 : CALL mpi_bcast(msg, msglen, MPI_LOGICAL, comm%source, comm%handle, ierr)
2586 670619 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2587 670619 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2588 : #else
2589 : MARK_USED(msg)
2590 : MARK_USED(comm)
2591 : #endif
2592 670619 : CALL mp_timestop(handle)
2593 670619 : END SUBROUTINE mp_bcast_b_src
2594 :
2595 : ! **************************************************************************************************
2596 : !> \brief ...
2597 : !> \param msg ...
2598 : !> \param source ...
2599 : !> \param comm ...
2600 : ! **************************************************************************************************
2601 0 : SUBROUTINE mp_bcast_bv(msg, source, comm)
2602 : LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2603 : INTEGER, INTENT(IN) :: source
2604 : CLASS(mp_comm_type), INTENT(IN) :: comm
2605 :
2606 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv'
2607 :
2608 : INTEGER :: handle
2609 : #if defined(__parallel)
2610 : INTEGER :: ierr, msglen
2611 : #endif
2612 :
2613 0 : CALL mp_timeset(routineN, handle)
2614 :
2615 : #if defined(__parallel)
2616 0 : msglen = SIZE(msg)
2617 0 : CALL mpi_bcast(msg, msglen, MPI_LOGICAL, source, comm%handle, ierr)
2618 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2619 0 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2620 : #else
2621 : MARK_USED(msg)
2622 : MARK_USED(source)
2623 : MARK_USED(comm)
2624 : #endif
2625 0 : CALL mp_timestop(handle)
2626 0 : END SUBROUTINE mp_bcast_bv
2627 :
2628 : ! **************************************************************************************************
2629 : !> \brief ...
2630 : !> \param msg ...
2631 : !> \param comm ...
2632 : ! **************************************************************************************************
2633 0 : SUBROUTINE mp_bcast_bv_src(msg, comm)
2634 : LOGICAL, CONTIGUOUS, INTENT(INOUT) :: msg(:)
2635 : CLASS(mp_comm_type), INTENT(IN) :: comm
2636 :
2637 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_bv_src'
2638 :
2639 : INTEGER :: handle
2640 : #if defined(__parallel)
2641 : INTEGER :: ierr, msglen
2642 : #endif
2643 :
2644 0 : CALL mp_timeset(routineN, handle)
2645 :
2646 : #if defined(__parallel)
2647 0 : msglen = SIZE(msg)
2648 0 : CALL mpi_bcast(msg, msglen, MPI_LOGICAL, comm%source, comm%handle, ierr)
2649 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2650 0 : CALL add_perf(perf_id=2, count=1, msg_size=msglen*loglen)
2651 : #else
2652 : MARK_USED(msg)
2653 : MARK_USED(comm)
2654 : #endif
2655 0 : CALL mp_timestop(handle)
2656 0 : END SUBROUTINE mp_bcast_bv_src
2657 :
2658 : ! **************************************************************************************************
2659 : !> \brief Non-blocking send of logical vector data
2660 : !> \param msgin the input message
2661 : !> \param dest the destination processor
2662 : !> \param comm the communicator object
2663 : !> \param request communication request index
2664 : !> \param tag message tag
2665 : !> \par History
2666 : !> 3.2016 added _bv subroutine [Nico Holmberg]
2667 : !> \author fawzi
2668 : !> \note see mp_irecv_iv
2669 : !> \note
2670 : !> arrays can be pointers or assumed shape, but they must be contiguous!
2671 : ! **************************************************************************************************
2672 16 : SUBROUTINE mp_isend_bv(msgin, dest, comm, request, tag)
2673 : LOGICAL, DIMENSION(:), INTENT(IN) :: msgin
2674 : INTEGER, INTENT(IN) :: dest
2675 : CLASS(mp_comm_type), INTENT(IN) :: comm
2676 : TYPE(mp_request_type), INTENT(out) :: request
2677 : INTEGER, INTENT(in), OPTIONAL :: tag
2678 :
2679 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bv'
2680 :
2681 : INTEGER :: handle
2682 : #if defined(__parallel)
2683 : INTEGER :: ierr, msglen, my_tag
2684 : LOGICAL :: foo(1)
2685 : #endif
2686 :
2687 16 : CALL mp_timeset(routineN, handle)
2688 :
2689 : #if defined(__parallel)
2690 : #if !defined(__GNUC__) || __GNUC__ >= 9
2691 16 : CPASSERT(IS_CONTIGUOUS(msgin))
2692 : #endif
2693 :
2694 16 : my_tag = 0
2695 16 : IF (PRESENT(tag)) my_tag = tag
2696 :
2697 16 : msglen = SIZE(msgin, 1)
2698 16 : IF (msglen > 0) THEN
2699 : CALL mpi_isend(msgin(1), msglen, MPI_LOGICAL, dest, my_tag, &
2700 16 : comm%handle, request%handle, ierr)
2701 : ELSE
2702 : CALL mpi_isend(foo, msglen, MPI_LOGICAL, dest, my_tag, &
2703 0 : comm%handle, request%handle, ierr)
2704 : END IF
2705 16 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
2706 :
2707 16 : CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
2708 : #else
2709 : CPABORT("mp_isend called in non parallel case")
2710 : MARK_USED(msgin)
2711 : MARK_USED(dest)
2712 : MARK_USED(comm)
2713 : MARK_USED(tag)
2714 : request = mp_request_null
2715 : #endif
2716 16 : CALL mp_timestop(handle)
2717 16 : END SUBROUTINE mp_isend_bv
2718 :
2719 : ! **************************************************************************************************
2720 : !> \brief Non-blocking receive of logical vector data
2721 : !> \param msgout the received message
2722 : !> \param source the source processor
2723 : !> \param comm the communicator object
2724 : !> \param request communication request index
2725 : !> \param tag message tag
2726 : !> \par History
2727 : !> 3.2016 added _bv subroutine [Nico Holmberg]
2728 : !> \author fawzi
2729 : !> \note see mp_irecv_iv
2730 : !> \note
2731 : !> arrays can be pointers or assumed shape, but they must be contiguous!
2732 : ! **************************************************************************************************
2733 16 : SUBROUTINE mp_irecv_bv(msgout, source, comm, request, tag)
2734 : LOGICAL, DIMENSION(:), INTENT(INOUT) :: msgout
2735 : INTEGER, INTENT(IN) :: source
2736 : CLASS(mp_comm_type), INTENT(IN) :: comm
2737 : TYPE(mp_request_type), INTENT(out) :: request
2738 : INTEGER, INTENT(in), OPTIONAL :: tag
2739 :
2740 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bv'
2741 :
2742 : INTEGER :: handle
2743 : #if defined(__parallel)
2744 : INTEGER :: ierr, msglen, my_tag
2745 : LOGICAL :: foo(1)
2746 : #endif
2747 :
2748 16 : CALL mp_timeset(routineN, handle)
2749 :
2750 : #if defined(__parallel)
2751 : #if !defined(__GNUC__) || __GNUC__ >= 9
2752 16 : CPASSERT(IS_CONTIGUOUS(msgout))
2753 : #endif
2754 :
2755 16 : my_tag = 0
2756 16 : IF (PRESENT(tag)) my_tag = tag
2757 :
2758 16 : msglen = SIZE(msgout, 1)
2759 16 : IF (msglen > 0) THEN
2760 : CALL mpi_irecv(msgout(1), msglen, MPI_LOGICAL, source, my_tag, &
2761 16 : comm%handle, request%handle, ierr)
2762 : ELSE
2763 : CALL mpi_irecv(foo, msglen, MPI_LOGICAL, source, my_tag, &
2764 0 : comm%handle, request%handle, ierr)
2765 : END IF
2766 16 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routineN)
2767 :
2768 16 : CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
2769 : #else
2770 : CPABORT("mp_irecv called in non parallel case")
2771 : MARK_USED(msgout)
2772 : MARK_USED(source)
2773 : MARK_USED(comm)
2774 : MARK_USED(tag)
2775 : request = mp_request_null
2776 : #endif
2777 16 : CALL mp_timestop(handle)
2778 16 : END SUBROUTINE mp_irecv_bv
2779 :
2780 : ! **************************************************************************************************
2781 : !> \brief Non-blocking send of rank-3 logical data
2782 : !> \param msgin the input message
2783 : !> \param dest the destination processor
2784 : !> \param comm the communicator object
2785 : !> \param request communication request index
2786 : !> \param tag message tag
2787 : !> \par History
2788 : !> 2.2016 added _bm3 subroutine [Nico Holmberg]
2789 : !> \author fawzi
2790 : !> \note see mp_irecv_iv
2791 : !> \note
2792 : !> arrays can be pointers or assumed shape, but they must be contiguous!
2793 : ! **************************************************************************************************
2794 0 : SUBROUTINE mp_isend_bm3(msgin, dest, comm, request, tag)
2795 : LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgin
2796 : INTEGER, INTENT(IN) :: dest
2797 : CLASS(mp_comm_type), INTENT(IN) :: comm
2798 : TYPE(mp_request_type), INTENT(out) :: request
2799 : INTEGER, INTENT(in), OPTIONAL :: tag
2800 :
2801 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isend_bm3'
2802 :
2803 : INTEGER :: handle
2804 : #if defined(__parallel)
2805 : INTEGER :: ierr, msglen, my_tag
2806 : LOGICAL :: foo(1)
2807 : #endif
2808 :
2809 0 : CALL mp_timeset(routineN, handle)
2810 :
2811 : #if defined(__parallel)
2812 : #if !defined(__GNUC__) || __GNUC__ >= 9
2813 0 : CPASSERT(IS_CONTIGUOUS(msgin))
2814 : #endif
2815 :
2816 0 : my_tag = 0
2817 0 : IF (PRESENT(tag)) my_tag = tag
2818 :
2819 0 : msglen = SIZE(msgin, 1)*SIZE(msgin, 2)*SIZE(msgin, 3)
2820 0 : IF (msglen > 0) THEN
2821 : CALL mpi_isend(msgin(1, 1, 1), msglen, MPI_LOGICAL, dest, my_tag, &
2822 0 : comm%handle, request%handle, ierr)
2823 : ELSE
2824 : CALL mpi_isend(foo, msglen, MPI_LOGICAL, dest, my_tag, &
2825 0 : comm%handle, request%handle, ierr)
2826 : END IF
2827 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ "//routineN)
2828 :
2829 0 : CALL add_perf(perf_id=11, count=1, msg_size=msglen*loglen)
2830 : #else
2831 : CPABORT("mp_isend called in non parallel case")
2832 : MARK_USED(msgin)
2833 : MARK_USED(dest)
2834 : MARK_USED(comm)
2835 : MARK_USED(tag)
2836 : request = mp_request_null
2837 : #endif
2838 0 : CALL mp_timestop(handle)
2839 0 : END SUBROUTINE mp_isend_bm3
2840 :
2841 : ! **************************************************************************************************
2842 : !> \brief Non-blocking receive of rank-3 logical data
2843 : !> \param msgout the received message
2844 : !> \param source the source processor
2845 : !> \param comm the communicator object
2846 : !> \param request communication request index
2847 : !> \param tag message tag
2848 : !> \par History
2849 : !> 2.2016 added _bm3 subroutine [Nico Holmberg]
2850 : !> \author fawzi
2851 : !> \note see mp_irecv_iv
2852 : !> \note
2853 : !> arrays can be pointers or assumed shape, but they must be contiguous!
2854 : ! **************************************************************************************************
2855 0 : SUBROUTINE mp_irecv_bm3(msgout, source, comm, request, tag)
2856 : LOGICAL, DIMENSION(:, :, :), INTENT(INOUT) :: msgout
2857 : INTEGER, INTENT(IN) :: source
2858 : CLASS(mp_comm_type), INTENT(IN) :: comm
2859 : TYPE(mp_request_type), INTENT(out) :: request
2860 : INTEGER, INTENT(in), OPTIONAL :: tag
2861 :
2862 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_irecv_bm3'
2863 :
2864 : INTEGER :: handle
2865 : #if defined(__parallel)
2866 : INTEGER :: ierr, msglen, my_tag
2867 : LOGICAL :: foo(1)
2868 : #endif
2869 :
2870 0 : CALL mp_timeset(routineN, handle)
2871 :
2872 : #if defined(__parallel)
2873 : #if !defined(__GNUC__) || __GNUC__ >= 9
2874 0 : CPASSERT(IS_CONTIGUOUS(msgout))
2875 : #endif
2876 :
2877 0 : my_tag = 0
2878 0 : IF (PRESENT(tag)) my_tag = tag
2879 :
2880 0 : msglen = SIZE(msgout, 1)*SIZE(msgout, 2)*SIZE(msgout, 3)
2881 0 : IF (msglen > 0) THEN
2882 : CALL mpi_irecv(msgout(1, 1, 1), msglen, MPI_LOGICAL, source, my_tag, &
2883 0 : comm%handle, request%handle, ierr)
2884 : ELSE
2885 : CALL mpi_irecv(foo, msglen, MPI_LOGICAL, source, my_tag, &
2886 0 : comm%handle, request%handle, ierr)
2887 : END IF
2888 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_ircv @ "//routineN)
2889 :
2890 0 : CALL add_perf(perf_id=12, count=1, msg_size=msglen*loglen)
2891 : #else
2892 : CPABORT("mp_irecv called in non parallel case")
2893 : MARK_USED(msgout)
2894 : MARK_USED(source)
2895 : MARK_USED(comm)
2896 : MARK_USED(request)
2897 : MARK_USED(tag)
2898 : request = mp_request_null
2899 : #endif
2900 0 : CALL mp_timestop(handle)
2901 0 : END SUBROUTINE mp_irecv_bm3
2902 :
2903 : ! **************************************************************************************************
2904 : !> \brief Broadcasts a string.
2905 : !> \param msg ...
2906 : !> \param source ...
2907 : !> \param comm ...
2908 : ! **************************************************************************************************
2909 3969806 : SUBROUTINE mp_bcast_av(msg, source, comm)
2910 : CHARACTER(LEN=*), INTENT(INOUT) :: msg
2911 : INTEGER, INTENT(IN) :: source
2912 : CLASS(mp_comm_type), INTENT(IN) :: comm
2913 :
2914 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av'
2915 :
2916 : INTEGER :: handle
2917 : #if defined(__parallel)
2918 : INTEGER :: ierr, msglen
2919 : #endif
2920 :
2921 3969806 : CALL mp_timeset(routineN, handle)
2922 :
2923 : #if defined(__parallel)
2924 3969806 : msglen = LEN(msg)*charlen
2925 3969806 : IF (comm%mepos /= source) msg = "" ! need to clear msg
2926 3969806 : CALL mpi_bcast(msg, msglen, MPI_CHARACTER, source, comm%handle, ierr)
2927 3969806 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2928 3969806 : CALL add_perf(perf_id=2, count=1, msg_size=msglen)
2929 : #else
2930 : MARK_USED(msg)
2931 : MARK_USED(source)
2932 : MARK_USED(comm)
2933 : #endif
2934 3969806 : CALL mp_timestop(handle)
2935 3969806 : END SUBROUTINE mp_bcast_av
2936 :
2937 : ! **************************************************************************************************
2938 : !> \brief Broadcasts a string.
2939 : !> \param msg ...
2940 : !> \param comm ...
2941 : ! **************************************************************************************************
2942 742 : SUBROUTINE mp_bcast_av_src(msg, comm)
2943 : CHARACTER(LEN=*), INTENT(INOUT) :: msg
2944 : CLASS(mp_comm_type), INTENT(IN) :: comm
2945 :
2946 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_av_src'
2947 :
2948 : INTEGER :: handle
2949 : #if defined(__parallel)
2950 : INTEGER :: ierr, msglen
2951 : #endif
2952 :
2953 742 : CALL mp_timeset(routineN, handle)
2954 :
2955 : #if defined(__parallel)
2956 742 : msglen = LEN(msg)*charlen
2957 742 : IF (.NOT. comm%is_source()) msg = "" ! need to clear msg
2958 742 : CALL mpi_bcast(msg, msglen, MPI_CHARACTER, comm%source, comm%handle, ierr)
2959 742 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2960 742 : CALL add_perf(perf_id=2, count=1, msg_size=msglen)
2961 : #else
2962 : MARK_USED(msg)
2963 : MARK_USED(comm)
2964 : #endif
2965 742 : CALL mp_timestop(handle)
2966 742 : END SUBROUTINE mp_bcast_av_src
2967 :
2968 : ! **************************************************************************************************
2969 : !> \brief ...
2970 : !> \param msg ...
2971 : !> \param source ...
2972 : !> \param comm ...
2973 : ! **************************************************************************************************
2974 28 : SUBROUTINE mp_bcast_am(msg, source, comm)
2975 : CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
2976 : INTEGER, INTENT(IN) :: source
2977 : CLASS(mp_comm_type), INTENT(IN) :: comm
2978 :
2979 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am'
2980 :
2981 : INTEGER :: handle
2982 : #if defined(__parallel)
2983 : INTEGER :: ierr, msglen
2984 : #endif
2985 :
2986 28 : CALL mp_timeset(routineN, handle)
2987 :
2988 : #if defined(__parallel)
2989 28 : msglen = SIZE(msg)*LEN(msg(1))*charlen
2990 1922 : IF (comm%mepos /= source) msg = "" ! need to clear msg
2991 28 : CALL mpi_bcast(msg, msglen, MPI_CHARACTER, source, comm%handle, ierr)
2992 28 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
2993 28 : CALL add_perf(perf_id=2, count=1, msg_size=msglen)
2994 : #else
2995 : MARK_USED(msg)
2996 : MARK_USED(source)
2997 : MARK_USED(comm)
2998 : #endif
2999 28 : CALL mp_timestop(handle)
3000 28 : END SUBROUTINE mp_bcast_am
3001 :
3002 80750 : SUBROUTINE mp_bcast_am_src(msg, comm)
3003 : CHARACTER(LEN=*), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3004 : CLASS(mp_comm_type), INTENT(IN) :: comm
3005 :
3006 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_bcast_am_src'
3007 :
3008 : INTEGER :: handle
3009 : #if defined(__parallel)
3010 : INTEGER :: ierr, msglen
3011 : #endif
3012 :
3013 80750 : CALL mp_timeset(routineN, handle)
3014 :
3015 : #if defined(__parallel)
3016 80750 : msglen = SIZE(msg)*LEN(msg(1))*charlen
3017 40455750 : IF (.NOT. comm%is_source()) msg = "" ! need to clear msg
3018 80750 : CALL mpi_bcast(msg, msglen, MPI_CHARACTER, comm%source, comm%handle, ierr)
3019 80750 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_bcast @ "//routineN)
3020 80750 : CALL add_perf(perf_id=2, count=1, msg_size=msglen)
3021 : #else
3022 : MARK_USED(msg)
3023 : MARK_USED(comm)
3024 : #endif
3025 80750 : CALL mp_timestop(handle)
3026 80750 : END SUBROUTINE mp_bcast_am_src
3027 :
3028 : ! **************************************************************************************************
3029 : !> \brief Finds the location of the minimal element in a vector.
3030 : !> \param[in,out] msg Find location of minimum element among these
3031 : !> data (input).
3032 : !> \param[in] comm Message passing environment identifier
3033 : !> \par MPI mapping
3034 : !> mpi_allreduce with the MPI_MINLOC reduction function identifier
3035 : !> \par Invalid data types
3036 : !> This routine is invalid for (int_8) data!
3037 : ! **************************************************************************************************
3038 310 : SUBROUTINE mp_minloc_dv(msg, comm)
3039 : REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3040 : CLASS(mp_comm_type), INTENT(IN) :: comm
3041 :
3042 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_dv'
3043 :
3044 : INTEGER :: handle
3045 : #if defined(__parallel)
3046 : INTEGER :: ierr, msglen
3047 310 : REAL(kind=real_8), ALLOCATABLE :: res(:)
3048 : #endif
3049 :
3050 : IF ("d" == "l" .AND. real_8 == int_8) THEN
3051 : CPABORT("Minimal location not available with long integers @ "//routineN)
3052 : END IF
3053 310 : CALL mp_timeset(routineN, handle)
3054 :
3055 : #if defined(__parallel)
3056 310 : msglen = SIZE(msg)
3057 930 : ALLOCATE (res(1:msglen), STAT=ierr)
3058 310 : IF (ierr /= 0) &
3059 0 : CPABORT("allocate @ "//routineN)
3060 310 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2DOUBLE_PRECISION, MPI_MINLOC, comm%handle, ierr)
3061 310 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3062 930 : msg = res
3063 310 : DEALLOCATE (res)
3064 310 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3065 : #else
3066 : MARK_USED(msg)
3067 : MARK_USED(comm)
3068 : #endif
3069 310 : CALL mp_timestop(handle)
3070 310 : END SUBROUTINE mp_minloc_dv
3071 :
3072 : ! **************************************************************************************************
3073 : !> \brief Finds the location of the minimal element in a vector.
3074 : !> \param[in,out] msg Find location of minimum element among these
3075 : !> data (input).
3076 : !> \param[in] comm Message passing environment identifier
3077 : !> \par MPI mapping
3078 : !> mpi_allreduce with the MPI_MINLOC reduction function identifier
3079 : !> \par Invalid data types
3080 : !> This routine is invalid for (int_8) data!
3081 : ! **************************************************************************************************
3082 0 : SUBROUTINE mp_minloc_iv(msg, comm)
3083 : INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3084 : CLASS(mp_comm_type), INTENT(IN) :: comm
3085 :
3086 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_iv'
3087 :
3088 : INTEGER :: handle
3089 : #if defined(__parallel)
3090 : INTEGER :: ierr, msglen
3091 0 : INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3092 : #endif
3093 :
3094 : IF ("i" == "l" .AND. int_4 == int_8) THEN
3095 : CPABORT("Minimal location not available with long integers @ "//routineN)
3096 : END IF
3097 0 : CALL mp_timeset(routineN, handle)
3098 :
3099 : #if defined(__parallel)
3100 0 : msglen = SIZE(msg)
3101 0 : ALLOCATE (res(1:msglen))
3102 0 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2INTEGER, MPI_MINLOC, comm%handle, ierr)
3103 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3104 0 : msg = res
3105 0 : DEALLOCATE (res)
3106 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3107 : #else
3108 : MARK_USED(msg)
3109 : MARK_USED(comm)
3110 : #endif
3111 0 : CALL mp_timestop(handle)
3112 0 : END SUBROUTINE mp_minloc_iv
3113 :
3114 : ! **************************************************************************************************
3115 : !> \brief Finds the location of the minimal element in a vector.
3116 : !> \param[in,out] msg Find location of minimum element among these
3117 : !> data (input).
3118 : !> \param[in] comm Message passing environment identifier
3119 : !> \par MPI mapping
3120 : !> mpi_allreduce with the MPI_MINLOC reduction function identifier
3121 : !> \par Invalid data types
3122 : !> This routine is invalid for (int_8) data!
3123 : ! **************************************************************************************************
3124 0 : SUBROUTINE mp_minloc_lv(msg, comm)
3125 : INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3126 : CLASS(mp_comm_type), INTENT(IN) :: comm
3127 :
3128 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_lv'
3129 :
3130 : INTEGER :: handle
3131 : #if defined(__parallel)
3132 : INTEGER :: ierr, msglen
3133 0 : INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3134 : #endif
3135 :
3136 : IF ("l" == "l" .AND. int_8 == int_8) THEN
3137 0 : CPABORT("Minimal location not available with long integers @ "//routineN)
3138 : END IF
3139 0 : CALL mp_timeset(routineN, handle)
3140 :
3141 : #if defined(__parallel)
3142 0 : msglen = SIZE(msg)
3143 0 : ALLOCATE (res(1:msglen))
3144 0 : CALL mpi_allreduce(msg, res, msglen/2, MPI_INTEGER8, MPI_MINLOC, comm%handle, ierr)
3145 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3146 0 : msg = res
3147 0 : DEALLOCATE (res)
3148 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3149 : #else
3150 : MARK_USED(msg)
3151 : MARK_USED(comm)
3152 : #endif
3153 0 : CALL mp_timestop(handle)
3154 0 : END SUBROUTINE mp_minloc_lv
3155 :
3156 : ! **************************************************************************************************
3157 : !> \brief Finds the location of the minimal element in a vector.
3158 : !> \param[in,out] msg Find location of minimum element among these
3159 : !> data (input).
3160 : !> \param[in] comm Message passing environment identifier
3161 : !> \par MPI mapping
3162 : !> mpi_allreduce with the MPI_MINLOC reduction function identifier
3163 : !> \par Invalid data types
3164 : !> This routine is invalid for (int_8) data!
3165 : ! **************************************************************************************************
3166 0 : SUBROUTINE mp_minloc_rv(msg, comm)
3167 : REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3168 : CLASS(mp_comm_type), INTENT(IN) :: comm
3169 :
3170 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_minloc_rv'
3171 :
3172 : INTEGER :: handle
3173 : #if defined(__parallel)
3174 : INTEGER :: ierr, msglen
3175 0 : REAL(kind=real_4), ALLOCATABLE :: res(:)
3176 : #endif
3177 :
3178 : IF ("r" == "l" .AND. real_4 == int_8) THEN
3179 : CPABORT("Minimal location not available with long integers @ "//routineN)
3180 : END IF
3181 0 : CALL mp_timeset(routineN, handle)
3182 :
3183 : #if defined(__parallel)
3184 0 : msglen = SIZE(msg)
3185 0 : ALLOCATE (res(1:msglen))
3186 0 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2REAL, MPI_MINLOC, comm%handle, ierr)
3187 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3188 0 : msg = res
3189 0 : DEALLOCATE (res)
3190 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3191 : #else
3192 : MARK_USED(msg)
3193 : MARK_USED(comm)
3194 : #endif
3195 0 : CALL mp_timestop(handle)
3196 0 : END SUBROUTINE mp_minloc_rv
3197 :
3198 : ! **************************************************************************************************
3199 : !> \brief Finds the location of the maximal element in a vector.
3200 : !> \param[in,out] msg Find location of maximum element among these
3201 : !> data (input).
3202 : !> \param[in] comm Message passing environment identifier
3203 : !> \par MPI mapping
3204 : !> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3205 : !> \par Invalid data types
3206 : !> This routine is invalid for (int_8) data!
3207 : ! **************************************************************************************************
3208 7926767 : SUBROUTINE mp_maxloc_dv(msg, comm)
3209 : REAL(kind=real_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3210 : CLASS(mp_comm_type), INTENT(IN) :: comm
3211 :
3212 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_dv'
3213 :
3214 : INTEGER :: handle
3215 : #if defined(__parallel)
3216 : INTEGER :: ierr, msglen
3217 7926767 : REAL(kind=real_8), ALLOCATABLE :: res(:)
3218 : #endif
3219 :
3220 : IF ("d" == "l" .AND. real_8 == int_8) THEN
3221 : CPABORT("Maximal location not available with long integers @ "//routineN)
3222 : END IF
3223 7926767 : CALL mp_timeset(routineN, handle)
3224 :
3225 : #if defined(__parallel)
3226 7926767 : msglen = SIZE(msg)
3227 23780301 : ALLOCATE (res(1:msglen))
3228 7926767 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2DOUBLE_PRECISION, MPI_MAXLOC, comm%handle, ierr)
3229 7926767 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3230 23780301 : msg = res
3231 7926767 : DEALLOCATE (res)
3232 7926767 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_8_size)
3233 : #else
3234 : MARK_USED(msg)
3235 : MARK_USED(comm)
3236 : #endif
3237 7926767 : CALL mp_timestop(handle)
3238 7926767 : END SUBROUTINE mp_maxloc_dv
3239 :
3240 : ! **************************************************************************************************
3241 : !> \brief Finds the location of the maximal element in a vector.
3242 : !> \param[in,out] msg Find location of maximum element among these
3243 : !> data (input).
3244 : !> \param[in] comm Message passing environment identifier
3245 : !> \par MPI mapping
3246 : !> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3247 : !> \par Invalid data types
3248 : !> This routine is invalid for (int_8) data!
3249 : ! **************************************************************************************************
3250 138 : SUBROUTINE mp_maxloc_iv(msg, comm)
3251 : INTEGER(KIND=int_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3252 : CLASS(mp_comm_type), INTENT(IN) :: comm
3253 :
3254 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_iv'
3255 :
3256 : INTEGER :: handle
3257 : #if defined(__parallel)
3258 : INTEGER :: ierr, msglen
3259 138 : INTEGER(KIND=int_4), ALLOCATABLE :: res(:)
3260 : #endif
3261 :
3262 : IF ("i" == "l" .AND. int_4 == int_8) THEN
3263 : CPABORT("Maximal location not available with long integers @ "//routineN)
3264 : END IF
3265 138 : CALL mp_timeset(routineN, handle)
3266 :
3267 : #if defined(__parallel)
3268 138 : msglen = SIZE(msg)
3269 414 : ALLOCATE (res(1:msglen))
3270 138 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2INTEGER, MPI_MAXLOC, comm%handle, ierr)
3271 138 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3272 414 : msg = res
3273 138 : DEALLOCATE (res)
3274 138 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_4_size)
3275 : #else
3276 : MARK_USED(msg)
3277 : MARK_USED(comm)
3278 : #endif
3279 138 : CALL mp_timestop(handle)
3280 138 : END SUBROUTINE mp_maxloc_iv
3281 :
3282 : ! **************************************************************************************************
3283 : !> \brief Finds the location of the maximal element in a vector.
3284 : !> \param[in,out] msg Find location of maximum element among these
3285 : !> data (input).
3286 : !> \param[in] comm Message passing environment identifier
3287 : !> \par MPI mapping
3288 : !> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3289 : !> \par Invalid data types
3290 : !> This routine is invalid for (int_8) data!
3291 : ! **************************************************************************************************
3292 0 : SUBROUTINE mp_maxloc_lv(msg, comm)
3293 : INTEGER(KIND=int_8), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3294 : CLASS(mp_comm_type), INTENT(IN) :: comm
3295 :
3296 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_lv'
3297 :
3298 : INTEGER :: handle
3299 : #if defined(__parallel)
3300 : INTEGER :: ierr, msglen
3301 0 : INTEGER(KIND=int_8), ALLOCATABLE :: res(:)
3302 : #endif
3303 :
3304 : IF ("l" == "l" .AND. int_8 == int_8) THEN
3305 0 : CPABORT("Maximal location not available with long integers @ "//routineN)
3306 : END IF
3307 0 : CALL mp_timeset(routineN, handle)
3308 :
3309 : #if defined(__parallel)
3310 0 : msglen = SIZE(msg)
3311 0 : ALLOCATE (res(1:msglen))
3312 0 : CALL mpi_allreduce(msg, res, msglen/2, MPI_INTEGER8, MPI_MAXLOC, comm%handle, ierr)
3313 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3314 0 : msg = res
3315 0 : DEALLOCATE (res)
3316 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*int_8_size)
3317 : #else
3318 : MARK_USED(msg)
3319 : MARK_USED(comm)
3320 : #endif
3321 0 : CALL mp_timestop(handle)
3322 0 : END SUBROUTINE mp_maxloc_lv
3323 :
3324 : ! **************************************************************************************************
3325 : !> \brief Finds the location of the maximal element in a vector.
3326 : !> \param[in,out] msg Find location of maximum element among these
3327 : !> data (input).
3328 : !> \param[in] comm Message passing environment identifier
3329 : !> \par MPI mapping
3330 : !> mpi_allreduce with the MPI_MAXLOC reduction function identifier
3331 : !> \par Invalid data types
3332 : !> This routine is invalid for (int_8) data!
3333 : ! **************************************************************************************************
3334 0 : SUBROUTINE mp_maxloc_rv(msg, comm)
3335 : REAL(kind=real_4), CONTIGUOUS, INTENT(INOUT) :: msg(:)
3336 : CLASS(mp_comm_type), INTENT(IN) :: comm
3337 :
3338 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_maxloc_rv'
3339 :
3340 : INTEGER :: handle
3341 : #if defined(__parallel)
3342 : INTEGER :: ierr, msglen
3343 0 : REAL(kind=real_4), ALLOCATABLE :: res(:)
3344 : #endif
3345 :
3346 : IF ("r" == "l" .AND. real_4 == int_8) THEN
3347 : CPABORT("Maximal location not available with long integers @ "//routineN)
3348 : END IF
3349 0 : CALL mp_timeset(routineN, handle)
3350 :
3351 : #if defined(__parallel)
3352 0 : msglen = SIZE(msg)
3353 0 : ALLOCATE (res(1:msglen))
3354 0 : CALL mpi_allreduce(msg, res, msglen/2, MPI_2REAL, MPI_MAXLOC, comm%handle, ierr)
3355 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3356 0 : msg = res
3357 0 : DEALLOCATE (res)
3358 0 : CALL add_perf(perf_id=3, count=1, msg_size=msglen*real_4_size)
3359 : #else
3360 : MARK_USED(msg)
3361 : MARK_USED(comm)
3362 : #endif
3363 0 : CALL mp_timestop(handle)
3364 0 : END SUBROUTINE mp_maxloc_rv
3365 :
3366 : ! **************************************************************************************************
3367 : !> \brief Logical OR reduction
3368 : !> \param[in,out] msg Datum to perform inclusive disjunction (input)
3369 : !> and resultant inclusive disjunction (output)
3370 : !> \param[in] comm Message passing environment identifier
3371 : !> \par MPI mapping
3372 : !> mpi_allreduce
3373 : ! **************************************************************************************************
3374 58746 : SUBROUTINE mp_sum_b(msg, comm)
3375 : LOGICAL, INTENT(INOUT) :: msg
3376 : CLASS(mp_comm_type), INTENT(IN) :: comm
3377 :
3378 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_b'
3379 :
3380 : INTEGER :: handle
3381 : #if defined(__parallel)
3382 : INTEGER :: ierr, msglen
3383 : #endif
3384 :
3385 58746 : CALL mp_timeset(routineN, handle)
3386 : #if defined(__parallel)
3387 58746 : msglen = 1
3388 58746 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, comm%handle, ierr)
3389 58746 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3390 : #else
3391 : MARK_USED(msg)
3392 : MARK_USED(comm)
3393 : #endif
3394 58746 : CALL mp_timestop(handle)
3395 58746 : END SUBROUTINE mp_sum_b
3396 :
3397 : ! **************************************************************************************************
3398 : !> \brief Logical OR reduction
3399 : !> \param[in,out] msg Datum to perform inclusive disjunction (input)
3400 : !> and resultant inclusive disjunction (output)
3401 : !> \param[in] comm Message passing environment identifier
3402 : !> \par MPI mapping
3403 : !> mpi_allreduce
3404 : ! **************************************************************************************************
3405 0 : SUBROUTINE mp_sum_bv(msg, comm)
3406 : LOGICAL, DIMENSION(:), CONTIGUOUS, INTENT(INOUT) :: msg
3407 : CLASS(mp_comm_type), INTENT(IN) :: comm
3408 :
3409 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_sum_bv'
3410 :
3411 : INTEGER :: handle
3412 : #if defined(__parallel)
3413 : INTEGER :: ierr, msglen
3414 : #endif
3415 :
3416 0 : CALL mp_timeset(routineN, handle)
3417 : #if defined(__parallel)
3418 0 : msglen = SIZE(msg)
3419 0 : IF (msglen > 0) THEN
3420 0 : CALL mpi_allreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, comm%handle, ierr)
3421 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3422 : END IF
3423 : #else
3424 : MARK_USED(msg)
3425 : MARK_USED(comm)
3426 : #endif
3427 0 : CALL mp_timestop(handle)
3428 0 : END SUBROUTINE mp_sum_bv
3429 :
3430 : ! **************************************************************************************************
3431 : !> \brief Logical OR reduction
3432 : !> \param[in,out] msg Datum to perform inclusive disjunction (input)
3433 : !> and resultant inclusive disjunction (output)
3434 : !> \param[in] comm Message passing environment identifier
3435 : !> \param request ...
3436 : !> \par MPI mapping
3437 : !> mpi_allreduce
3438 : ! **************************************************************************************************
3439 0 : SUBROUTINE mp_isum_bv(msg, comm, request)
3440 : LOGICAL, DIMENSION(:), INTENT(INOUT) :: msg
3441 : CLASS(mp_comm_type), INTENT(IN) :: comm
3442 : TYPE(mp_request_type), INTENT(INOUT) :: request
3443 :
3444 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_isum_bv'
3445 :
3446 : INTEGER :: handle
3447 : #if defined(__parallel)
3448 : INTEGER :: ierr, msglen
3449 : #endif
3450 :
3451 0 : CALL mp_timeset(routineN, handle)
3452 : #if defined(__parallel)
3453 0 : msglen = SIZE(msg)
3454 : #if !defined(__GNUC__) || __GNUC__ >= 9
3455 0 : CPASSERT(IS_CONTIGUOUS(msg))
3456 : #endif
3457 :
3458 0 : IF (msglen > 0) THEN
3459 0 : CALL mpi_iallreduce(MPI_IN_PLACE, msg, msglen, MPI_LOGICAL, MPI_LOR, comm%handle, request%handle, ierr)
3460 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_allreduce @ "//routineN)
3461 : ELSE
3462 0 : request = mp_request_null
3463 : END IF
3464 : #else
3465 : MARK_USED(msg)
3466 : MARK_USED(comm)
3467 : request = mp_request_null
3468 : #endif
3469 0 : CALL mp_timestop(handle)
3470 0 : END SUBROUTINE mp_isum_bv
3471 :
3472 : ! **************************************************************************************************
3473 : !> \brief Get Version of the MPI Library (MPI 3)
3474 : !> \param[out] version Version of the library,
3475 : !> declared as CHARACTER(LEN=mp_max_library_version_string)
3476 : !> \param[out] resultlen Length (in printable characters) of
3477 : !> the result returned in version (integer)
3478 : ! **************************************************************************************************
3479 0 : SUBROUTINE mp_get_library_version(version, resultlen)
3480 : CHARACTER(len=*), INTENT(OUT) :: version
3481 : INTEGER, INTENT(OUT) :: resultlen
3482 :
3483 : #if defined(__parallel)
3484 : INTEGER :: ierr
3485 : #endif
3486 :
3487 0 : version = ''
3488 :
3489 : #if defined(__parallel)
3490 : ierr = 0
3491 0 : CALL mpi_get_library_version(version, resultlen, ierr)
3492 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_get_library_version @ mp_get_library_version")
3493 : #else
3494 : resultlen = 0
3495 : #endif
3496 0 : END SUBROUTINE mp_get_library_version
3497 :
3498 : ! **************************************************************************************************
3499 : !> \brief Opens a file
3500 : !> \param[in] groupid message passing environment identifier
3501 : !> \param[out] fh file handle (file storage unit)
3502 : !> \param[in] filepath path to the file
3503 : !> \param amode_status access mode
3504 : !> \param info ...
3505 : !> \par MPI-I/O mapping mpi_file_open
3506 : !> \par STREAM-I/O mapping OPEN
3507 : !>
3508 : !> \param[in](optional) info info object
3509 : !> \par History
3510 : !> 11.2012 created [Hossein Bani-Hashemian]
3511 : ! **************************************************************************************************
3512 1888 : SUBROUTINE mp_file_open(groupid, fh, filepath, amode_status, info)
3513 : CLASS(mp_comm_type), INTENT(IN) :: groupid
3514 : CLASS(mp_file_type), INTENT(OUT) :: fh
3515 : CHARACTER(len=*), INTENT(IN) :: filepath
3516 : INTEGER, INTENT(IN) :: amode_status
3517 : TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3518 :
3519 : #if defined(__parallel)
3520 : INTEGER :: ierr
3521 : MPI_INFO_TYPE :: my_info
3522 : #else
3523 : CHARACTER(LEN=10) :: fstatus, fposition
3524 : INTEGER :: amode, handle, istat
3525 : LOGICAL :: exists, is_open
3526 : #endif
3527 :
3528 : #if defined(__parallel)
3529 : ierr = 0
3530 1888 : my_info = mpi_info_null
3531 1888 : IF (PRESENT(info)) my_info = info%handle
3532 1888 : CALL mpi_file_open(groupid%handle, filepath, amode_status, my_info, fh%handle, ierr)
3533 1888 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
3534 1888 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_open")
3535 : #else
3536 : MARK_USED(groupid)
3537 : MARK_USED(info)
3538 : amode = amode_status
3539 : IF (amode > file_amode_append) THEN
3540 : fposition = "APPEND"
3541 : amode = amode - file_amode_append
3542 : ELSE
3543 : fposition = "REWIND"
3544 : END IF
3545 : IF ((amode == file_amode_create) .OR. &
3546 : (amode == file_amode_create + file_amode_wronly) .OR. &
3547 : (amode == file_amode_create + file_amode_wronly + file_amode_excl)) THEN
3548 : fstatus = "UNKNOWN"
3549 : ELSE
3550 : fstatus = "OLD"
3551 : END IF
3552 : ! Get a new unit number
3553 : DO handle = 1, 999
3554 : INQUIRE (UNIT=handle, EXIST=exists, OPENED=is_open, IOSTAT=istat)
3555 : IF (exists .AND. (.NOT. is_open) .AND. (istat == 0)) EXIT
3556 : END DO
3557 : OPEN (UNIT=handle, FILE=filepath, STATUS=fstatus, ACCESS="STREAM", POSITION=fposition)
3558 : fh%handle = handle
3559 : #endif
3560 1888 : END SUBROUTINE mp_file_open
3561 :
3562 : ! **************************************************************************************************
3563 : !> \brief Deletes a file. Auxiliary routine to emulate 'replace' action for mp_file_open.
3564 : !> Only the master processor should call this routine.
3565 : !> \param[in] filepath path to the file
3566 : !> \param[in](optional) info info object
3567 : !> \par History
3568 : !> 11.2017 created [Nico Holmberg]
3569 : ! **************************************************************************************************
3570 162 : SUBROUTINE mp_file_delete(filepath, info)
3571 : CHARACTER(len=*), INTENT(IN) :: filepath
3572 : TYPE(mp_info_type), INTENT(IN), OPTIONAL :: info
3573 :
3574 : #if defined(__parallel)
3575 : INTEGER :: ierr
3576 : MPI_INFO_TYPE :: my_info
3577 : LOGICAL :: exists
3578 :
3579 162 : ierr = 0
3580 162 : my_info = mpi_info_null
3581 162 : IF (PRESENT(info)) my_info = info%handle
3582 162 : INQUIRE (FILE=filepath, EXIST=exists)
3583 162 : IF (exists) CALL mpi_file_delete(filepath, my_info, ierr)
3584 162 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_delete")
3585 : #else
3586 : MARK_USED(filepath)
3587 : MARK_USED(info)
3588 : ! Explicit file delete not necessary, handled by subsequent call to open_file with action 'replace'
3589 : #endif
3590 :
3591 162 : END SUBROUTINE mp_file_delete
3592 :
3593 : ! **************************************************************************************************
3594 : !> \brief Closes a file
3595 : !> \param[in] fh file handle (file storage unit)
3596 : !> \par MPI-I/O mapping mpi_file_close
3597 : !> \par STREAM-I/O mapping CLOSE
3598 : !>
3599 : !> \par History
3600 : !> 11.2012 created [Hossein Bani-Hashemian]
3601 : ! **************************************************************************************************
3602 3776 : SUBROUTINE mp_file_close(fh)
3603 : CLASS(mp_file_type), INTENT(INOUT) :: fh
3604 :
3605 : #if defined(__parallel)
3606 : INTEGER :: ierr
3607 :
3608 : ierr = 0
3609 1888 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
3610 1888 : CALL mpi_file_close(fh%handle, ierr)
3611 1888 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_close")
3612 : #else
3613 : CLOSE (fh%handle)
3614 : fh%handle = mp_file_null_handle
3615 : #endif
3616 1888 : END SUBROUTINE mp_file_close
3617 :
3618 0 : SUBROUTINE mp_file_assign(fh_new, fh_old)
3619 : CLASS(mp_file_type), INTENT(OUT) :: fh_new
3620 : CLASS(mp_file_type), INTENT(IN) :: fh_old
3621 :
3622 0 : fh_new%handle = fh_old%handle
3623 :
3624 0 : END SUBROUTINE
3625 :
3626 : ! **************************************************************************************************
3627 : !> \brief Returns the file size
3628 : !> \param[in] fh file handle (file storage unit)
3629 : !> \param[out] file_size the file size
3630 : !> \par MPI-I/O mapping mpi_file_get_size
3631 : !> \par STREAM-I/O mapping INQUIRE
3632 : !>
3633 : !> \par History
3634 : !> 12.2012 created [Hossein Bani-Hashemian]
3635 : ! **************************************************************************************************
3636 0 : SUBROUTINE mp_file_get_size(fh, file_size)
3637 : CLASS(mp_file_type), INTENT(IN) :: fh
3638 : INTEGER(kind=file_offset), INTENT(OUT) :: file_size
3639 :
3640 : #if defined(__parallel)
3641 : INTEGER :: ierr
3642 : #endif
3643 :
3644 : #if defined(__parallel)
3645 : ierr = 0
3646 0 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
3647 0 : CALL mpi_file_get_size(fh%handle, file_size, ierr)
3648 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_size")
3649 : #else
3650 : INQUIRE (UNIT=fh%handle, SIZE=file_size)
3651 : #endif
3652 0 : END SUBROUTINE mp_file_get_size
3653 :
3654 : ! **************************************************************************************************
3655 : !> \brief Returns the file position
3656 : !> \param[in] fh file handle (file storage unit)
3657 : !> \param[out] file_size the file position
3658 : !> \par MPI-I/O mapping mpi_file_get_position
3659 : !> \par STREAM-I/O mapping INQUIRE
3660 : !>
3661 : !> \par History
3662 : !> 11.2017 created [Nico Holmberg]
3663 : ! **************************************************************************************************
3664 3700 : SUBROUTINE mp_file_get_position(fh, pos)
3665 : CLASS(mp_file_type), INTENT(IN) :: fh
3666 : INTEGER(kind=file_offset), INTENT(OUT) :: pos
3667 :
3668 : #if defined(__parallel)
3669 : INTEGER :: ierr
3670 : #endif
3671 :
3672 : #if defined(__parallel)
3673 : ierr = 0
3674 1850 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
3675 1850 : CALL mpi_file_get_position(fh%handle, pos, ierr)
3676 1850 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ mp_file_get_position")
3677 : #else
3678 : INQUIRE (UNIT=fh%handle, POS=pos)
3679 : #endif
3680 1850 : END SUBROUTINE mp_file_get_position
3681 :
3682 : ! **************************************************************************************************
3683 : !> \brief (parallel) Blocking individual file write using explicit offsets
3684 : !> (serial) Unformatted stream write
3685 : !> \param[in] fh file handle (file storage unit)
3686 : !> \param[in] offset file offset (position)
3687 : !> \param[in] msg data to be written to the file
3688 : !> \param msglen ...
3689 : !> \par MPI-I/O mapping mpi_file_write_at
3690 : !> \par STREAM-I/O mapping WRITE
3691 : !> \param[in](optional) msglen number of the elements of data
3692 : ! **************************************************************************************************
3693 0 : SUBROUTINE mp_file_write_at_chv(fh, offset, msg, msglen)
3694 : CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
3695 : CLASS(mp_file_type), INTENT(IN) :: fh
3696 : INTEGER, INTENT(IN), OPTIONAL :: msglen
3697 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3698 :
3699 : #if defined(__parallel)
3700 : INTEGER :: ierr, msg_len
3701 : #endif
3702 :
3703 : #if defined(__parallel)
3704 0 : msg_len = SIZE(msg)
3705 0 : IF (PRESENT(msglen)) msg_len = msglen
3706 0 : CALL MPI_FILE_WRITE_AT(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3707 0 : IF (ierr /= 0) &
3708 0 : CPABORT("mpi_file_write_at_chv @ mp_file_write_at_chv")
3709 : #else
3710 : MARK_USED(msglen)
3711 : WRITE (UNIT=fh%handle, POS=offset + 1) msg
3712 : #endif
3713 0 : END SUBROUTINE mp_file_write_at_chv
3714 :
3715 : ! **************************************************************************************************
3716 : !> \brief ...
3717 : !> \param fh ...
3718 : !> \param offset ...
3719 : !> \param msg ...
3720 : ! **************************************************************************************************
3721 8692 : SUBROUTINE mp_file_write_at_ch(fh, offset, msg)
3722 : CHARACTER(LEN=*), INTENT(IN) :: msg
3723 : CLASS(mp_file_type), INTENT(IN) :: fh
3724 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3725 :
3726 : #if defined(__parallel)
3727 : INTEGER :: ierr
3728 : #endif
3729 :
3730 : #if defined(__parallel)
3731 8692 : CALL MPI_FILE_WRITE_AT(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3732 8692 : IF (ierr /= 0) &
3733 0 : CPABORT("mpi_file_write_at_ch @ mp_file_write_at_ch")
3734 : #else
3735 : WRITE (UNIT=fh%handle, POS=offset + 1) msg
3736 : #endif
3737 8692 : END SUBROUTINE mp_file_write_at_ch
3738 :
3739 : ! **************************************************************************************************
3740 : !> \brief (parallel) Blocking collective file write using explicit offsets
3741 : !> (serial) Unformatted stream write
3742 : !> \param fh ...
3743 : !> \param offset ...
3744 : !> \param msg ...
3745 : !> \param msglen ...
3746 : !> \par MPI-I/O mapping mpi_file_write_at_all
3747 : !> \par STREAM-I/O mapping WRITE
3748 : ! **************************************************************************************************
3749 0 : SUBROUTINE mp_file_write_at_all_chv(fh, offset, msg, msglen)
3750 : CHARACTER, CONTIGUOUS, INTENT(IN) :: msg(:)
3751 : CLASS(mp_file_type), INTENT(IN) :: fh
3752 : INTEGER, INTENT(IN), OPTIONAL :: msglen
3753 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3754 :
3755 : #if defined(__parallel)
3756 : INTEGER :: ierr, msg_len
3757 : #endif
3758 :
3759 : #if defined(__parallel)
3760 0 : msg_len = SIZE(msg)
3761 0 : IF (PRESENT(msglen)) msg_len = msglen
3762 0 : CALL MPI_FILE_WRITE_AT_ALL(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3763 0 : IF (ierr /= 0) &
3764 0 : CPABORT("mpi_file_write_at_all_chv @ mp_file_write_at_all_chv")
3765 : #else
3766 : MARK_USED(msglen)
3767 : WRITE (UNIT=fh%handle, POS=offset + 1) msg
3768 : #endif
3769 0 : END SUBROUTINE mp_file_write_at_all_chv
3770 :
3771 : ! **************************************************************************************************
3772 : !> \brief wrapper to MPI_File_write_at_all
3773 : !> \param fh ...
3774 : !> \param offset ...
3775 : !> \param msg ...
3776 : ! **************************************************************************************************
3777 0 : SUBROUTINE mp_file_write_at_all_ch(fh, offset, msg)
3778 : CHARACTER(LEN=*), INTENT(IN) :: msg
3779 : CLASS(mp_file_type), INTENT(IN) :: fh
3780 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3781 :
3782 : #if defined(__parallel)
3783 : INTEGER :: ierr
3784 : #endif
3785 :
3786 : #if defined(__parallel)
3787 0 : CALL MPI_FILE_WRITE_AT_ALL(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3788 0 : IF (ierr /= 0) &
3789 0 : CPABORT("mpi_file_write_at_all_ch @ mp_file_write_at_all_ch")
3790 : #else
3791 : WRITE (UNIT=fh%handle, POS=offset + 1) msg
3792 : #endif
3793 0 : END SUBROUTINE mp_file_write_at_all_ch
3794 :
3795 : ! **************************************************************************************************
3796 : !> \brief (parallel) Blocking individual file read using explicit offsets
3797 : !> (serial) Unformatted stream read
3798 : !> \param[in] fh file handle (file storage unit)
3799 : !> \param[in] offset file offset (position)
3800 : !> \param[out] msg data to be read from the file
3801 : !> \param msglen ...
3802 : !> \par MPI-I/O mapping mpi_file_read_at
3803 : !> \par STREAM-I/O mapping READ
3804 : !> \param[in](optional) msglen number of elements of data
3805 : ! **************************************************************************************************
3806 0 : SUBROUTINE mp_file_read_at_chv(fh, offset, msg, msglen)
3807 : CHARACTER, CONTIGUOUS, INTENT(OUT) :: msg(:)
3808 : CLASS(mp_file_type), INTENT(IN) :: fh
3809 : INTEGER, INTENT(IN), OPTIONAL :: msglen
3810 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3811 :
3812 : #if defined(__parallel)
3813 : INTEGER :: ierr, msg_len
3814 : #endif
3815 :
3816 : #if defined(__parallel)
3817 0 : msg_len = SIZE(msg)
3818 0 : IF (PRESENT(msglen)) msg_len = msglen
3819 0 : CALL MPI_FILE_READ_AT(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3820 0 : IF (ierr /= 0) &
3821 0 : CPABORT("mpi_file_read_at_chv @ mp_file_read_at_chv")
3822 : #else
3823 : MARK_USED(msglen)
3824 : READ (UNIT=fh%handle, POS=offset + 1) msg
3825 : #endif
3826 0 : END SUBROUTINE mp_file_read_at_chv
3827 :
3828 : ! **************************************************************************************************
3829 : !> \brief wrapper to MPI_File_read_at
3830 : !> \param fh ...
3831 : !> \param offset ...
3832 : !> \param msg ...
3833 : ! **************************************************************************************************
3834 0 : SUBROUTINE mp_file_read_at_ch(fh, offset, msg)
3835 : CHARACTER(LEN=*), INTENT(OUT) :: msg
3836 : CLASS(mp_file_type), INTENT(IN) :: fh
3837 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3838 :
3839 : #if defined(__parallel)
3840 : INTEGER :: ierr
3841 : #endif
3842 :
3843 : #if defined(__parallel)
3844 0 : CALL MPI_FILE_READ_AT(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3845 0 : IF (ierr /= 0) &
3846 0 : CPABORT("mpi_file_read_at_ch @ mp_file_read_at_ch")
3847 : #else
3848 : READ (UNIT=fh%handle, POS=offset + 1) msg
3849 : #endif
3850 0 : END SUBROUTINE mp_file_read_at_ch
3851 :
3852 : ! **************************************************************************************************
3853 : !> \brief (parallel) Blocking collective file read using explicit offsets
3854 : !> (serial) Unformatted stream read
3855 : !> \param fh ...
3856 : !> \param offset ...
3857 : !> \param msg ...
3858 : !> \param msglen ...
3859 : !> \par MPI-I/O mapping mpi_file_read_at_all
3860 : !> \par STREAM-I/O mapping READ
3861 : ! **************************************************************************************************
3862 0 : SUBROUTINE mp_file_read_at_all_chv(fh, offset, msg, msglen)
3863 : CHARACTER, INTENT(OUT) :: msg(:)
3864 : CLASS(mp_file_type), INTENT(IN) :: fh
3865 : INTEGER, INTENT(IN), OPTIONAL :: msglen
3866 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3867 :
3868 : #if defined(__parallel)
3869 : INTEGER :: ierr, msg_len
3870 : #endif
3871 :
3872 : #if defined(__parallel)
3873 0 : msg_len = SIZE(msg)
3874 0 : IF (PRESENT(msglen)) msg_len = msglen
3875 0 : CALL MPI_FILE_READ_AT_ALL(fh%handle, offset, msg, msg_len, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3876 0 : IF (ierr /= 0) &
3877 0 : CPABORT("mpi_file_read_at_all_chv @ mp_file_read_at_all_chv")
3878 : #else
3879 : MARK_USED(msglen)
3880 : READ (UNIT=fh%handle, POS=offset + 1) msg
3881 : #endif
3882 0 : END SUBROUTINE mp_file_read_at_all_chv
3883 :
3884 : ! **************************************************************************************************
3885 : !> \brief wrapper to MPI_File_read_at_all
3886 : !> \param fh ...
3887 : !> \param offset ...
3888 : !> \param msg ...
3889 : ! **************************************************************************************************
3890 0 : SUBROUTINE mp_file_read_at_all_ch(fh, offset, msg)
3891 : CHARACTER(LEN=*), INTENT(OUT) :: msg
3892 : CLASS(mp_file_type), INTENT(IN) :: fh
3893 : INTEGER(kind=file_offset), INTENT(IN) :: offset
3894 :
3895 : #if defined(__parallel)
3896 : INTEGER :: ierr
3897 : #endif
3898 :
3899 : #if defined(__parallel)
3900 0 : CALL MPI_FILE_READ_AT_ALL(fh%handle, offset, msg, LEN(msg), MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
3901 0 : IF (ierr /= 0) &
3902 0 : CPABORT("mpi_file_read_at_all_ch @ mp_file_read_at_all_ch")
3903 : #else
3904 : READ (UNIT=fh%handle, POS=offset + 1) msg
3905 : #endif
3906 0 : END SUBROUTINE mp_file_read_at_all_ch
3907 :
3908 : ! **************************************************************************************************
3909 : !> \brief Returns the size of a data type in bytes
3910 : !> \param[in] type_descriptor data type
3911 : !> \param[out] type_size size of the data type
3912 : !> \par MPI mapping
3913 : !> mpi_type_size
3914 : !>
3915 : ! **************************************************************************************************
3916 0 : SUBROUTINE mp_type_size(type_descriptor, type_size)
3917 : TYPE(mp_type_descriptor_type), INTENT(IN) :: type_descriptor
3918 : INTEGER, INTENT(OUT) :: type_size
3919 :
3920 : #if defined(__parallel)
3921 : INTEGER :: ierr
3922 :
3923 : ierr = 0
3924 0 : CALL MPI_TYPE_SIZE(type_descriptor%type_handle, type_size, ierr)
3925 0 : IF (ierr /= 0) &
3926 0 : CPABORT("mpi_type_size failed @ mp_type_size")
3927 : #else
3928 : SELECT CASE (type_descriptor%type_handle)
3929 : CASE (1)
3930 : type_size = real_4_size
3931 : CASE (3)
3932 : type_size = real_8_size
3933 : CASE (5)
3934 : type_size = 2*real_4_size
3935 : CASE (7)
3936 : type_size = 2*real_8_size
3937 : END SELECT
3938 : #endif
3939 0 : END SUBROUTINE mp_type_size
3940 :
3941 : ! **************************************************************************************************
3942 : !> \brief wrapper to MPI_Type_create_struct
3943 : !> \param subtypes ...
3944 : !> \param vector_descriptor ...
3945 : !> \param index_descriptor ...
3946 : !> \return ...
3947 : ! **************************************************************************************************
3948 0 : FUNCTION mp_type_make_struct(subtypes, &
3949 : vector_descriptor, index_descriptor) &
3950 : RESULT(type_descriptor)
3951 : TYPE(mp_type_descriptor_type), &
3952 : DIMENSION(:), INTENT(IN) :: subtypes
3953 : INTEGER, DIMENSION(2), INTENT(IN), &
3954 : OPTIONAL :: vector_descriptor
3955 : TYPE(mp_indexing_meta_type), &
3956 : INTENT(IN), OPTIONAL :: index_descriptor
3957 : TYPE(mp_type_descriptor_type) :: type_descriptor
3958 :
3959 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_type_make_struct'
3960 :
3961 : INTEGER :: i, n
3962 0 : INTEGER, ALLOCATABLE, DIMENSION(:) :: lengths
3963 : #if defined(__parallel)
3964 : INTEGER :: ierr
3965 : INTEGER(kind=mpi_address_kind), &
3966 0 : ALLOCATABLE, DIMENSION(:) :: displacements
3967 : #if defined(__MPI_F08)
3968 : ! Even OpenMPI 5.x misses mpi_get_address in the F08 interface
3969 : EXTERNAL :: mpi_get_address
3970 : #endif
3971 : #endif
3972 0 : MPI_DATA_TYPE, ALLOCATABLE, DIMENSION(:) :: old_types
3973 :
3974 0 : n = SIZE(subtypes)
3975 0 : type_descriptor%length = 1
3976 : #if defined(__parallel)
3977 0 : ierr = 0
3978 0 : CALL mpi_get_address(MPI_BOTTOM, type_descriptor%base, ierr)
3979 0 : IF (ierr /= 0) &
3980 0 : CPABORT("MPI_get_address @ "//routineN)
3981 0 : ALLOCATE (displacements(n))
3982 : #endif
3983 0 : type_descriptor%vector_descriptor(1:2) = 1
3984 0 : type_descriptor%has_indexing = .FALSE.
3985 0 : ALLOCATE (type_descriptor%subtype(n))
3986 0 : type_descriptor%subtype(:) = subtypes(:)
3987 0 : ALLOCATE (lengths(n), old_types(n))
3988 0 : DO i = 1, SIZE(subtypes)
3989 : #if defined(__parallel)
3990 0 : displacements(i) = subtypes(i)%base
3991 : #endif
3992 0 : old_types(i) = subtypes(i)%type_handle
3993 0 : lengths(i) = subtypes(i)%length
3994 : END DO
3995 : #if defined(__parallel)
3996 : CALL MPI_Type_create_struct(n, &
3997 : lengths, displacements, old_types, &
3998 0 : type_descriptor%type_handle, ierr)
3999 0 : IF (ierr /= 0) &
4000 0 : CPABORT("MPI_Type_create_struct @ "//routineN)
4001 0 : CALL MPI_Type_commit(type_descriptor%type_handle, ierr)
4002 0 : IF (ierr /= 0) &
4003 0 : CPABORT("MPI_Type_commit @ "//routineN)
4004 : #endif
4005 0 : IF (PRESENT(vector_descriptor) .OR. PRESENT(index_descriptor)) THEN
4006 0 : CPABORT(routineN//" Vectors and indices NYI")
4007 : END IF
4008 0 : END FUNCTION mp_type_make_struct
4009 :
4010 : ! **************************************************************************************************
4011 : !> \brief wrapper to MPI_Type_free
4012 : !> \param type_descriptor ...
4013 : ! **************************************************************************************************
4014 0 : RECURSIVE SUBROUTINE mp_type_free_m(type_descriptor)
4015 : TYPE(mp_type_descriptor_type), INTENT(inout) :: type_descriptor
4016 :
4017 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_type_free_m'
4018 :
4019 : INTEGER :: handle, i
4020 : #if defined(__parallel)
4021 : INTEGER :: ierr
4022 : #endif
4023 :
4024 0 : CALL mp_timeset(routineN, handle)
4025 :
4026 : ! If the subtype is associated, then it's a user-defined data type.
4027 :
4028 0 : IF (ASSOCIATED(type_descriptor%subtype)) THEN
4029 0 : DO i = 1, SIZE(type_descriptor%subtype)
4030 0 : CALL mp_type_free_m(type_descriptor%subtype(i))
4031 : END DO
4032 0 : DEALLOCATE (type_descriptor%subtype)
4033 : END IF
4034 : #if defined(__parallel)
4035 : ierr = 0
4036 0 : CALL MPI_Type_free(type_descriptor%type_handle, ierr)
4037 0 : IF (ierr /= 0) &
4038 0 : CPABORT("MPI_Type_free @ "//routineN)
4039 : #endif
4040 :
4041 0 : CALL mp_timestop(handle)
4042 :
4043 0 : END SUBROUTINE mp_type_free_m
4044 :
4045 : ! **************************************************************************************************
4046 : !> \brief ...
4047 : !> \param type_descriptors ...
4048 : ! **************************************************************************************************
4049 0 : SUBROUTINE mp_type_free_v(type_descriptors)
4050 : TYPE(mp_type_descriptor_type), DIMENSION(:), &
4051 : INTENT(inout) :: type_descriptors
4052 :
4053 : INTEGER :: i
4054 :
4055 0 : DO i = 1, SIZE(type_descriptors)
4056 0 : CALL mp_type_free(type_descriptors(i))
4057 : END DO
4058 :
4059 0 : END SUBROUTINE mp_type_free_v
4060 :
4061 : ! **************************************************************************************************
4062 : !> \brief Creates an indexed MPI type for arrays of strings using bytes for spacing (hindexed type)
4063 : !> \param count number of array blocks to read
4064 : !> \param lengths lengths of each array block
4065 : !> \param displs byte offsets for array blocks
4066 : !> \return container holding the created type
4067 : !> \author Nico Holmberg [05.2017]
4068 : ! **************************************************************************************************
4069 3776 : FUNCTION mp_file_type_hindexed_make_chv(count, lengths, displs) &
4070 : RESULT(type_descriptor)
4071 : INTEGER, INTENT(IN) :: count
4072 : INTEGER, DIMENSION(1:count), &
4073 : INTENT(IN), TARGET :: lengths
4074 : INTEGER(kind=file_offset), &
4075 : DIMENSION(1:count), INTENT(in), TARGET :: displs
4076 : TYPE(mp_file_descriptor_type) :: type_descriptor
4077 :
4078 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_hindexed_make_chv'
4079 :
4080 : INTEGER :: ierr, handle
4081 :
4082 : ierr = 0
4083 1888 : CALL mp_timeset(routineN, handle)
4084 :
4085 : #if defined(__parallel)
4086 : CALL MPI_Type_create_hindexed(count, lengths, INT(displs, KIND=address_kind), MPI_CHARACTER, &
4087 405894 : type_descriptor%type_handle, ierr)
4088 1888 : IF (ierr /= 0) &
4089 0 : CPABORT("MPI_Type_create_hindexed @ "//routineN)
4090 1888 : CALL MPI_Type_commit(type_descriptor%type_handle, ierr)
4091 1888 : IF (ierr /= 0) &
4092 0 : CPABORT("MPI_Type_commit @ "//routineN)
4093 : #else
4094 : type_descriptor%type_handle = 68
4095 : #endif
4096 1888 : type_descriptor%length = count
4097 1888 : type_descriptor%has_indexing = .TRUE.
4098 1888 : type_descriptor%index_descriptor%index => lengths
4099 1888 : type_descriptor%index_descriptor%chunks => displs
4100 :
4101 1888 : CALL mp_timestop(handle)
4102 :
4103 1888 : END FUNCTION mp_file_type_hindexed_make_chv
4104 :
4105 : ! **************************************************************************************************
4106 : !> \brief Uses a previously created indexed MPI character type to tell the MPI processes
4107 : !> how to partition (set_view) an opened file
4108 : !> \param fh the file handle associated with the input file
4109 : !> \param offset global offset determining where the relevant data begins
4110 : !> \param type_descriptor container for the MPI type
4111 : !> \author Nico Holmberg [05.2017]
4112 : ! **************************************************************************************************
4113 1888 : SUBROUTINE mp_file_type_set_view_chv(fh, offset, type_descriptor)
4114 : TYPE(mp_file_type), INTENT(IN) :: fh
4115 : INTEGER(kind=file_offset), INTENT(IN) :: offset
4116 : TYPE(mp_file_descriptor_type) :: type_descriptor
4117 :
4118 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_set_view_chv'
4119 :
4120 : INTEGER :: handle
4121 : #if defined(__parallel)
4122 : INTEGER :: ierr
4123 : #endif
4124 :
4125 1888 : CALL mp_timeset(routineN, handle)
4126 :
4127 : #if defined(__parallel)
4128 : ierr = 0
4129 1888 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
4130 : CALL MPI_File_set_view(fh%handle, offset, MPI_CHARACTER, &
4131 1888 : type_descriptor%type_handle, "native", MPI_INFO_NULL, ierr)
4132 1888 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_set_view")
4133 : #else
4134 : ! Uses absolute offsets stored in mp_file_descriptor_type
4135 : MARK_USED(fh)
4136 : MARK_USED(offset)
4137 : MARK_USED(type_descriptor)
4138 : #endif
4139 :
4140 1888 : CALL mp_timestop(handle)
4141 :
4142 1888 : END SUBROUTINE mp_file_type_set_view_chv
4143 :
4144 : ! **************************************************************************************************
4145 : !> \brief (parallel) Collective, blocking read of a character array from a file. File access pattern
4146 : ! determined by a previously set file view.
4147 : !> (serial) Unformatted stream read using explicit offsets
4148 : !> \param fh the file handle associated with the input file
4149 : !> \param msglen the message length of an individual vector component
4150 : !> \param ndims the number of vector components
4151 : !> \param buffer the buffer where the data is placed
4152 : !> \param type_descriptor container for the MPI type
4153 : !> \author Nico Holmberg [05.2017]
4154 : ! **************************************************************************************************
4155 38 : SUBROUTINE mp_file_read_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4156 : CLASS(mp_file_type), INTENT(IN) :: fh
4157 : INTEGER, INTENT(IN) :: msglen
4158 : INTEGER, INTENT(IN) :: ndims
4159 : CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(INOUT) :: buffer
4160 : TYPE(mp_file_descriptor_type), &
4161 : INTENT(IN), OPTIONAL :: type_descriptor
4162 :
4163 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_read_all_chv'
4164 :
4165 : INTEGER :: handle
4166 : #if defined(__parallel)
4167 : INTEGER:: ierr
4168 : #else
4169 : INTEGER :: i
4170 : #endif
4171 :
4172 38 : CALL mp_timeset(routineN, handle)
4173 :
4174 : #if defined(__parallel)
4175 : ierr = 0
4176 : MARK_USED(type_descriptor)
4177 38 : CALL MPI_File_read_all(fh%handle, buffer, ndims*msglen, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
4178 38 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_read_all")
4179 38 : CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4180 : #else
4181 : MARK_USED(msglen)
4182 : MARK_USED(ndims)
4183 : IF (.NOT. PRESENT(type_descriptor)) &
4184 : CALL cp_abort(__LOCATION__, &
4185 : "Container for mp_file_descriptor_type must be present in serial call.")
4186 : IF (.NOT. type_descriptor%has_indexing) &
4187 : CALL cp_abort(__LOCATION__, &
4188 : "File view has not been set in mp_file_descriptor_type.")
4189 : ! Use explicit offsets
4190 : DO i = 1, ndims
4191 : READ (fh%handle, POS=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4192 : END DO
4193 : #endif
4194 :
4195 38 : CALL mp_timestop(handle)
4196 :
4197 38 : END SUBROUTINE mp_file_read_all_chv
4198 :
4199 : ! **************************************************************************************************
4200 : !> \brief (parallel) Collective, blocking write of a character array to a file. File access pattern
4201 : ! determined by a previously set file view.
4202 : !> (serial) Unformatted stream write using explicit offsets
4203 : !> \param fh the file handle associated with the output file
4204 : !> \param msglen the message length of an individual vector component
4205 : !> \param ndims the number of vector components
4206 : !> \param buffer the buffer where the data is placed
4207 : !> \param type_descriptor container for the MPI type
4208 : !> \author Nico Holmberg [05.2017]
4209 : ! **************************************************************************************************
4210 1850 : SUBROUTINE mp_file_write_all_chv(fh, msglen, ndims, buffer, type_descriptor)
4211 : CLASS(mp_file_type), INTENT(IN) :: fh
4212 : INTEGER, INTENT(IN) :: msglen
4213 : INTEGER, INTENT(IN) :: ndims
4214 : CHARACTER(LEN=msglen), DIMENSION(ndims), INTENT(IN) :: buffer
4215 : TYPE(mp_file_descriptor_type), &
4216 : INTENT(IN), OPTIONAL :: type_descriptor
4217 :
4218 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_write_all_chv'
4219 :
4220 : INTEGER :: handle
4221 : #if defined(__parallel)
4222 : INTEGER :: ierr
4223 : #else
4224 : INTEGER :: i
4225 : #endif
4226 :
4227 1850 : CALL mp_timeset(routineN, handle)
4228 :
4229 : #if defined(__parallel)
4230 : MARK_USED(type_descriptor)
4231 1850 : CALL mpi_file_set_errhandler(fh%handle, MPI_ERRORS_RETURN, ierr)
4232 1850 : CALL MPI_File_write_all(fh%handle, buffer, ndims*msglen, MPI_CHARACTER, MPI_STATUS_IGNORE, ierr)
4233 1850 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_file_set_errhandler @ MPI_File_write_all")
4234 1850 : CALL add_perf(perf_id=28, count=1, msg_size=ndims*msglen)
4235 : #else
4236 : MARK_USED(msglen)
4237 : MARK_USED(ndims)
4238 : IF (.NOT. PRESENT(type_descriptor)) &
4239 : CALL cp_abort(__LOCATION__, &
4240 : "Container for mp_file_descriptor_type must be present in serial call.")
4241 : IF (.NOT. type_descriptor%has_indexing) &
4242 : CALL cp_abort(__LOCATION__, &
4243 : "File view has not been set in mp_file_descriptor_type.")
4244 : ! Use explicit offsets
4245 : DO i = 1, ndims
4246 : WRITE (fh%handle, POS=type_descriptor%index_descriptor%chunks(i)) buffer(i)
4247 : END DO
4248 : #endif
4249 :
4250 1850 : CALL mp_timestop(handle)
4251 :
4252 1850 : END SUBROUTINE mp_file_write_all_chv
4253 :
4254 : ! **************************************************************************************************
4255 : !> \brief Releases the type used for MPI I/O
4256 : !> \param type_descriptor the container for the MPI type
4257 : !> \author Nico Holmberg [05.2017]
4258 : ! **************************************************************************************************
4259 3776 : SUBROUTINE mp_file_type_free(type_descriptor)
4260 : TYPE(mp_file_descriptor_type) :: type_descriptor
4261 :
4262 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_file_type_free'
4263 :
4264 : INTEGER :: handle
4265 : #if defined(__parallel)
4266 : INTEGER :: ierr
4267 : #endif
4268 :
4269 1888 : CALL mp_timeset(routineN, handle)
4270 :
4271 : #if defined(__parallel)
4272 1888 : CALL MPI_Type_free(type_descriptor%type_handle, ierr)
4273 1888 : IF (ierr /= 0) &
4274 0 : CPABORT("MPI_Type_free @ "//routineN)
4275 : #endif
4276 : #if defined(__parallel) && defined(__MPI_F08)
4277 1888 : type_descriptor%type_handle%mpi_val = -1
4278 : #else
4279 : type_descriptor%type_handle = -1
4280 : #endif
4281 1888 : type_descriptor%length = -1
4282 1888 : IF (type_descriptor%has_indexing) THEN
4283 1888 : NULLIFY (type_descriptor%index_descriptor%index)
4284 1888 : NULLIFY (type_descriptor%index_descriptor%chunks)
4285 1888 : type_descriptor%has_indexing = .FALSE.
4286 : END IF
4287 :
4288 1888 : CALL mp_timestop(handle)
4289 :
4290 1888 : END SUBROUTINE mp_file_type_free
4291 :
4292 : ! **************************************************************************************************
4293 : !> \brief (parallel) Utility routine to determine MPI file access mode based on variables
4294 : ! that in the serial case would get passed to the intrinsic OPEN
4295 : !> (serial) No action
4296 : !> \param mpi_io flag that determines if MPI I/O will actually be used
4297 : !> \param replace flag that indicates whether file needs to be deleted prior to opening it
4298 : !> \param amode the MPI I/O access mode
4299 : !> \param form formatted or unformatted data?
4300 : !> \param action the variable that determines what to do with file
4301 : !> \param status the status flag:
4302 : !> \param position should the file be appended or rewound
4303 : !> \author Nico Holmberg [11.2017]
4304 : ! **************************************************************************************************
4305 1850 : SUBROUTINE mp_file_get_amode(mpi_io, replace, amode, form, action, status, position)
4306 : LOGICAL, INTENT(INOUT) :: mpi_io, replace
4307 : INTEGER, INTENT(OUT) :: amode
4308 : CHARACTER(len=*), INTENT(IN) :: form, action, status, position
4309 :
4310 1850 : amode = -1
4311 : #if defined(__parallel)
4312 : ! Disable mpi io for unformatted access
4313 0 : SELECT CASE (form)
4314 : CASE ("FORMATTED")
4315 : ! Do nothing
4316 : CASE ("UNFORMATTED")
4317 0 : mpi_io = .FALSE.
4318 : CASE DEFAULT
4319 1850 : CPABORT("Unknown MPI file form requested.")
4320 : END SELECT
4321 : ! Determine file access mode (limited set of allowed choices)
4322 1850 : SELECT CASE (action)
4323 : CASE ("WRITE")
4324 1850 : amode = file_amode_wronly
4325 0 : SELECT CASE (status)
4326 : CASE ("NEW")
4327 : ! Try to open new file for writing, crash if file already exists
4328 0 : amode = amode + file_amode_create + file_amode_excl
4329 : CASE ("UNKNOWN")
4330 : ! Open file for writing and create it if file does not exist
4331 1526 : amode = amode + file_amode_create
4332 76 : SELECT CASE (position)
4333 : CASE ("APPEND")
4334 : ! Append existing file
4335 76 : amode = amode + file_amode_append
4336 : CASE ("REWIND", "ASIS")
4337 : ! Do nothing
4338 : CASE DEFAULT
4339 1526 : CPABORT("Unknown MPI file position requested.")
4340 : END SELECT
4341 : CASE ("OLD")
4342 324 : SELECT CASE (position)
4343 : CASE ("APPEND")
4344 : ! Append existing file
4345 0 : amode = amode + file_amode_append
4346 : CASE ("REWIND", "ASIS")
4347 : ! Do nothing
4348 : CASE DEFAULT
4349 0 : CPABORT("Unknown MPI file position requested.")
4350 : END SELECT
4351 : CASE ("REPLACE")
4352 : ! Overwrite existing file. Must delete existing file first
4353 324 : amode = amode + file_amode_create
4354 324 : replace = .TRUE.
4355 : CASE ("SCRATCH")
4356 : ! Disable
4357 0 : mpi_io = .FALSE.
4358 : CASE DEFAULT
4359 1850 : CPABORT("Unknown MPI file status requested.")
4360 : END SELECT
4361 : CASE ("READ")
4362 0 : amode = file_amode_rdonly
4363 0 : SELECT CASE (status)
4364 : CASE ("NEW")
4365 0 : CPABORT("Cannot read from 'NEW' file.")
4366 : CASE ("REPLACE")
4367 0 : CPABORT("Illegal status 'REPLACE' for read.")
4368 : CASE ("UNKNOWN", "OLD")
4369 : ! Do nothing
4370 : CASE ("SCRATCH")
4371 : ! Disable
4372 0 : mpi_io = .FALSE.
4373 : CASE DEFAULT
4374 0 : CPABORT("Unknown MPI file status requested.")
4375 : END SELECT
4376 : CASE ("READWRITE")
4377 0 : amode = file_amode_rdwr
4378 0 : SELECT CASE (status)
4379 : CASE ("NEW")
4380 : ! Try to open new file, crash if file already exists
4381 0 : amode = amode + file_amode_create + file_amode_excl
4382 : CASE ("UNKNOWN")
4383 : ! Open file and create it if file does not exist
4384 0 : amode = amode + file_amode_create
4385 0 : SELECT CASE (position)
4386 : CASE ("APPEND")
4387 : ! Append existing file
4388 0 : amode = amode + file_amode_append
4389 : CASE ("REWIND", "ASIS")
4390 : ! Do nothing
4391 : CASE DEFAULT
4392 0 : CPABORT("Unknown MPI file position requested.")
4393 : END SELECT
4394 : CASE ("OLD")
4395 0 : SELECT CASE (position)
4396 : CASE ("APPEND")
4397 : ! Append existing file
4398 0 : amode = amode + file_amode_append
4399 : CASE ("REWIND", "ASIS")
4400 : ! Do nothing
4401 : CASE DEFAULT
4402 0 : CPABORT("Unknown MPI file position requested.")
4403 : END SELECT
4404 : CASE ("REPLACE")
4405 : ! Overwrite existing file. Must delete existing file first
4406 0 : amode = amode + file_amode_create
4407 0 : replace = .TRUE.
4408 : CASE ("SCRATCH")
4409 : ! Disable
4410 0 : mpi_io = .FALSE.
4411 : CASE DEFAULT
4412 0 : CPABORT("Unknown MPI file status requested.")
4413 : END SELECT
4414 : CASE DEFAULT
4415 1850 : CPABORT("Unknown MPI file action requested.")
4416 : END SELECT
4417 : #else
4418 : MARK_USED(replace)
4419 : MARK_USED(form)
4420 : MARK_USED(position)
4421 : MARK_USED(status)
4422 : MARK_USED(action)
4423 : mpi_io = .FALSE.
4424 : #endif
4425 :
4426 1850 : END SUBROUTINE mp_file_get_amode
4427 :
4428 : ! **************************************************************************************************
4429 : !> \brief Non-blocking send of custom type
4430 : !> \param msgin ...
4431 : !> \param dest ...
4432 : !> \param comm ...
4433 : !> \param request ...
4434 : !> \param tag ...
4435 : ! **************************************************************************************************
4436 0 : SUBROUTINE mp_isend_custom(msgin, dest, comm, request, tag)
4437 : TYPE(mp_type_descriptor_type), INTENT(IN) :: msgin
4438 : INTEGER, INTENT(IN) :: dest
4439 : CLASS(mp_comm_type), INTENT(IN) :: comm
4440 : TYPE(mp_request_type), INTENT(out) :: request
4441 : INTEGER, INTENT(in), OPTIONAL :: tag
4442 :
4443 : INTEGER :: ierr, my_tag
4444 :
4445 : ierr = 0
4446 0 : my_tag = 0
4447 :
4448 : #if defined(__parallel)
4449 0 : IF (PRESENT(tag)) my_tag = tag
4450 :
4451 : CALL mpi_isend(MPI_BOTTOM, 1, msgin%type_handle, dest, my_tag, &
4452 0 : comm%handle, request%handle, ierr)
4453 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_isend @ mp_isend_custom")
4454 : #else
4455 : MARK_USED(msgin)
4456 : MARK_USED(dest)
4457 : MARK_USED(comm)
4458 : MARK_USED(tag)
4459 : ierr = 1
4460 : request = mp_request_null
4461 : CALL mp_stop(ierr, "mp_isend called in non parallel case")
4462 : #endif
4463 0 : END SUBROUTINE mp_isend_custom
4464 :
4465 : ! **************************************************************************************************
4466 : !> \brief Non-blocking receive of vector data
4467 : !> \param msgout ...
4468 : !> \param source ...
4469 : !> \param comm ...
4470 : !> \param request ...
4471 : !> \param tag ...
4472 : ! **************************************************************************************************
4473 0 : SUBROUTINE mp_irecv_custom(msgout, source, comm, request, tag)
4474 : TYPE(mp_type_descriptor_type), INTENT(INOUT) :: msgout
4475 : INTEGER, INTENT(IN) :: source
4476 : CLASS(mp_comm_type), INTENT(IN) :: comm
4477 : TYPE(mp_request_type), INTENT(out) :: request
4478 : INTEGER, INTENT(in), OPTIONAL :: tag
4479 :
4480 : INTEGER :: ierr, my_tag
4481 :
4482 : ierr = 0
4483 0 : my_tag = 0
4484 :
4485 : #if defined(__parallel)
4486 0 : IF (PRESENT(tag)) my_tag = tag
4487 :
4488 : CALL mpi_irecv(MPI_BOTTOM, 1, msgout%type_handle, source, my_tag, &
4489 0 : comm%handle, request%handle, ierr)
4490 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_irecv @ mp_irecv_custom")
4491 : #else
4492 : MARK_USED(msgout)
4493 : MARK_USED(source)
4494 : MARK_USED(comm)
4495 : MARK_USED(tag)
4496 : ierr = 1
4497 : request = mp_request_null
4498 : CPABORT("mp_irecv called in non parallel case")
4499 : #endif
4500 0 : END SUBROUTINE mp_irecv_custom
4501 :
4502 : ! **************************************************************************************************
4503 : !> \brief Window free
4504 : !> \param win ...
4505 : ! **************************************************************************************************
4506 0 : SUBROUTINE mp_win_free(win)
4507 : CLASS(mp_win_type), INTENT(INOUT) :: win
4508 :
4509 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_free'
4510 :
4511 : INTEGER :: handle
4512 : #if defined(__parallel)
4513 : INTEGER :: ierr
4514 : #endif
4515 :
4516 0 : CALL mp_timeset(routineN, handle)
4517 :
4518 : #if defined(__parallel)
4519 : ierr = 0
4520 0 : CALL mpi_win_free(win%handle, ierr)
4521 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_free @ "//routineN)
4522 :
4523 0 : CALL add_perf(perf_id=21, count=1)
4524 : #else
4525 : win%handle = mp_win_null_handle
4526 : #endif
4527 0 : CALL mp_timestop(handle)
4528 0 : END SUBROUTINE mp_win_free
4529 :
4530 0 : SUBROUTINE mp_win_assign(win_new, win_old)
4531 : CLASS(mp_win_type), INTENT(OUT) :: win_new
4532 : CLASS(mp_win_type), INTENT(IN) :: win_old
4533 :
4534 0 : win_new%handle = win_old%handle
4535 :
4536 0 : END SUBROUTINE mp_win_assign
4537 :
4538 : ! **************************************************************************************************
4539 : !> \brief Window flush
4540 : !> \param win ...
4541 : ! **************************************************************************************************
4542 0 : SUBROUTINE mp_win_flush_all(win)
4543 : CLASS(mp_win_type), INTENT(IN) :: win
4544 :
4545 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_flush_all'
4546 :
4547 : INTEGER :: handle, ierr
4548 :
4549 : ierr = 0
4550 0 : CALL mp_timeset(routineN, handle)
4551 :
4552 : #if defined(__parallel)
4553 0 : CALL mpi_win_flush_all(win%handle, ierr)
4554 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_flush_all @ "//routineN)
4555 : #else
4556 : MARK_USED(win)
4557 : #endif
4558 0 : CALL mp_timestop(handle)
4559 0 : END SUBROUTINE mp_win_flush_all
4560 :
4561 : ! **************************************************************************************************
4562 : !> \brief Window lock
4563 : !> \param win ...
4564 : ! **************************************************************************************************
4565 0 : SUBROUTINE mp_win_lock_all(win)
4566 : CLASS(mp_win_type), INTENT(IN) :: win
4567 :
4568 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_lock_all'
4569 :
4570 : INTEGER :: handle, ierr
4571 :
4572 : ierr = 0
4573 0 : CALL mp_timeset(routineN, handle)
4574 :
4575 : #if defined(__parallel)
4576 :
4577 0 : CALL mpi_win_lock_all(MPI_MODE_NOCHECK, win%handle, ierr)
4578 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_lock_all @ "//routineN)
4579 :
4580 0 : CALL add_perf(perf_id=19, count=1)
4581 : #else
4582 : MARK_USED(win)
4583 : #endif
4584 0 : CALL mp_timestop(handle)
4585 0 : END SUBROUTINE mp_win_lock_all
4586 :
4587 : ! **************************************************************************************************
4588 : !> \brief Window lock
4589 : !> \param win ...
4590 : ! **************************************************************************************************
4591 0 : SUBROUTINE mp_win_unlock_all(win)
4592 : CLASS(mp_win_type), INTENT(IN) :: win
4593 :
4594 : CHARACTER(len=*), PARAMETER :: routineN = 'mp_win_unlock_all'
4595 :
4596 : INTEGER :: handle, ierr
4597 :
4598 : ierr = 0
4599 0 : CALL mp_timeset(routineN, handle)
4600 :
4601 : #if defined(__parallel)
4602 :
4603 0 : CALL mpi_win_unlock_all(win%handle, ierr)
4604 0 : IF (ierr /= 0) CALL mp_stop(ierr, "mpi_win_unlock_all @ "//routineN)
4605 :
4606 0 : CALL add_perf(perf_id=19, count=1)
4607 : #else
4608 : MARK_USED(win)
4609 : #endif
4610 0 : CALL mp_timestop(handle)
4611 0 : END SUBROUTINE mp_win_unlock_all
4612 :
4613 : ! **************************************************************************************************
4614 : !> \brief Starts a timer region
4615 : !> \param routineN ...
4616 : !> \param handle ...
4617 : ! **************************************************************************************************
4618 139324513 : SUBROUTINE mp_timeset(routineN, handle)
4619 : CHARACTER(len=*), INTENT(IN) :: routineN
4620 : INTEGER, INTENT(OUT) :: handle
4621 :
4622 139324513 : IF (mp_collect_timings) &
4623 139133227 : CALL timeset(routineN, handle)
4624 139324513 : END SUBROUTINE mp_timeset
4625 :
4626 : ! **************************************************************************************************
4627 : !> \brief Ends a timer region
4628 : !> \param handle ...
4629 : ! **************************************************************************************************
4630 139324513 : SUBROUTINE mp_timestop(handle)
4631 : INTEGER, INTENT(IN) :: handle
4632 :
4633 139324513 : IF (mp_collect_timings) &
4634 139133227 : CALL timestop(handle)
4635 139324513 : END SUBROUTINE mp_timestop
4636 :
4637 : #:include 'message_passing.fypp'
4638 :
4639 65464911 : END MODULE message_passing
|
