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