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