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