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