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