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