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